home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / nuc / yerk368.txt < prev   
Encoding:
Text File  |  1995-11-23  |  78.7 KB  |  3,637 lines  |  [TEXT/MASM]
  1. ; System 7 modifications
  2. ; courier 9pt -9 spacing tabs: .875 1.5 3.625
  3. ; need to change modification in vers RSRC
  4. ; flush caches in trap; fix d0 saves for flushes
  5. ; fixed s,; added ucase in word_
  6. ; 6/1/94 changed at1,2,4 to not use (sp)+,-
  7. ; 3.66=3.64
  8. ;    Load equates for Toolbox, Quickdraw
  9.     LIST OFF
  10.     INCLUDE    "library.asm"
  11.     INCLUDE    "equates.asm"
  12.     INCLUDE    "yerk.macro"
  13. *
  14. gestalt    EQU    $a1ad
  15. newhandc    EQU    $a322
  16. newPtrc    EQU    $a31e
  17. stripAddress    EQU    $a055
  18. waitNextEvt    EQU    $a860
  19. HWPriv    EQU    $a198
  20.     GLOBAL    $200,$200
  21.     ENDG
  22.     TFILE "YERK.BIN"
  23.     RFILE "YERK",APPL,YERK,$2100    ; has bundle,init
  24. ;
  25. Rsize    EQU    400    ; Maximum depth of ret+mstack
  26. Rbytes    EQU    -Rsize*4    ; Number of bytes for ret+mstack
  27. MSbytes    EQU    1200    ; 300 cells on methods stack
  28. sysVects    EQU    17    ; how many system vectors + 1 (for len)
  29. sysVecSz    EQU    sysVects*4    ; total len of system vector table
  30. ; 'SAVE' HEADER EQUATES.
  31. udp    EQU    0    ; User dictionary pointer
  32. ufence    EQU    4    ; User fence pointer
  33. uvocl    EQU    8    ; User vocabulary pointer
  34. ulatest    EQU    12    ; Latest NFA.
  35. headlen    EQU    16    ; Length of header
  36. ; Finder Handle Offsets
  37. opflag    EQU    0    ; Open/Print flag
  38. numfiles    EQU    2    ; Number of files
  39. volrnum    EQU    0    ; Volume reference number
  40. ftype    EQU    2    ; File type
  41. fvernum    EQU    6    ; File's version number
  42. fname    EQU    8    ; File name ( <count> <name> )
  43. f.handle    EQU    16    ; Offset to finder handle
  44. *
  45.     SEG    1,48
  46.     bra.s    start
  47. installed    data    /0    ; 0 if cold; 1 if warm; 2 if application
  48. getInstL    lea    installed(PC),a2    ; get Installed address in a2
  49.     rts
  50. start
  51.     lea    installed(PC),a2    ; see if this is a reboot
  52.     btst    #0,(a2)    ; if true, mem already acquired,
  53.     bne.s    already    ; skip initialization code
  54.     sjsr    getDict    ; load seg & get user dict size in d1
  55.     clr.l    -(sp)
  56.     move.l    #$434F4445,-(sp)    ; CODE
  57.     move.w    #2,-(sp)
  58.     _getResource
  59.     move.l    (sp),a0    ; keep handle on stack
  60.     clr.l    -(sp)    ; set up to get size of seg 2
  61.     move.l    a0,-(sp)
  62.     _SizeRsrc
  63.     move.l    (sp)+,d2    ; got size in d2
  64.     move.l    (sp),a0    ; recover handle
  65.     _Hunlock
  66.     btst    #1,(a2)    ; if true, this is application
  67.     bne.s    isApp    ; don't change code size
  68.     add.l    d2,d1    ; add nucleus length
  69. isApp    move.l    d1,d0
  70.     _SetHandleSize
  71.     tst.l    d0    ; did we get it?
  72.     beq.s    gotit
  73.     move.w    #3,-(sp)
  74.     _sysbeep
  75.     _exitToShell
  76. gotit
  77.     move.l    (sp)+,a0
  78.     _Hlock
  79.     lea    installed(PC),a0
  80.     ori.b    #1,(a0)    ; set true for installed
  81.     sjmp    origin
  82. already
  83.     sjmp    coldvec
  84.     ENDR
  85. *
  86.     SEG    2,48
  87. ;        begin USER initialization data
  88. origin    bra    ftInit    ; branch around initialization da
  89. one    EQU    origin
  90. segStart    EQU    origin-4
  91. lkorigin    EQU    origin    ; null link for first entry
  92. yerkID   ASC     "3680"          ; Release, version, revision, 0
  93.          ADJST
  94. initLast DATA    Lastdef-origin  ; origin + 8: last definition addr
  95. initFenc DATA    Lastdef-origin  ; fence
  96. initS0   DATA    0    ; offset from A3 for initial A7 (SP)
  97. initR0   DATA    0    ; offset from A3 for initial A6
  98. initmp   DATA    0    ; offset from A3 for initial D5
  99. initDP    DATA    0    ; DP - starts past sys vector table
  100. initVocl    DATA    0    ; VOC-LINK - last COLD init
  101. Userror    DATA    0    ; Error during load
  102. memsize    DATA    300000    ; user dictionary size for CODE2
  103. memPtr    DATA    0    ; abs ptr to the user dict heap
  104. userdp    DATA    0    ; Pointer to the user dict heap
  105. stksize    DATA    $ffffd120    ; 12000 stack size
  106. ;
  107. ;    End USER initialization data
  108. ;
  109. ftInit
  110.     link    a6,#rbytes    ; a6=R0,a7=S0 return stack
  111.     pea    -4(a5)
  112.     _InitGraf    ; initGraf(@thePort)
  113.     lea    origin(PC),a3    ; a3 -> code base at load
  114.     lea    stksize(PC),a0
  115.     move.l    (a0),d1
  116.     lea    0(a7,d1.l),a0    ; leave stack space
  117.     _setApplLimit
  118.     _MaxApplZone
  119.     _maxMem        ; force purge of the heap
  120. *
  121.     sjsr    getInstL    ; see if this is a reboot-from seg0
  122.     btst    #1,(a2)    ; if true, this is a program, so skip next
  123.     bne.s    noload
  124.     jsr    loaduser(PC)    ; load application dictionary if any
  125. noload    moveq    #(initS0-origin),d7    ; put offset into D7
  126.     move.l    SP,d0    ; store SP in d0
  127.     sub.l    a3,d0    ; reference to yerk base
  128.     move.l    d0,0(a3,d7.l)    ; inits0 now has offset to data stk
  129.     move.l    a6,d0    ; A6 points to methods stack
  130.     sub.l    a3,d0    ; reference to yerk base
  131.     lea    initmp(PC),a2    ; Init methods stack for cold load
  132.     move.l    d0,(a2)    ; initmp now has mstack offset
  133.     subi.l    #msbytes,d0    ; Leave 300 cells for M stack
  134.     move.l    d0,4(a3,d7.l)    ; initr0 now has offset to ret stk
  135. *
  136. COLDVEC    bra.s    ECLD    ; jump to cold start
  137. WARMVEC    bra.s    EWRM    ; jump to warm start
  138. ; =======Inner Interpreter ===========
  139. donext    move.l    (a4)+,d6    ; get next threaded instruction (32bit)
  140.     move.l    0(a3,d6.l),d7    ; get code address
  141.     jmp    0(a3,d7.l)    ; jump to code addr relative to a3
  142.     nop
  143. ECLD    movea.l    #applScratch,a2    ; fill scratch with warm start
  144.     move.w    #$4ef9,(a2)+    ; jmp
  145.     lea    ewrm(PC),a0
  146.     move.l    a0,(a2)    
  147. *
  148.     lea    cld1(PC),a4    ; A4 is IP in inner interpreter
  149.     bra.s    EWRM1
  150. EWRM    lea    warm1(PC),a4    ; A4 is IP in inner interpreter
  151. EWRM1    lea    origin(PC),a3
  152.     moveq    #(initS0-origin),d7    ; get address of initS0 in D7
  153.     movea.l    0(a3,d7.l),SP    ; pickup s0 address in SP
  154.     adda.l    a3,SP
  155.     movea.l    4(a3,d7.l),a6    ; pickup r0 address in a6
  156.     adda.l    a3,a6
  157.     move.l    initmp(PC),d5    ; Pick methods stack pointer
  158.     add.l    a3,d5
  159.     gonext
  160. ;
  161. ; GETDICT call from seg 0
  162. getDict    lea    memsize(PC),a1
  163.     move.l    (a1),d1
  164.     rts
  165. ;
  166. warm1    cfas    cls,abort,semis
  167. ; Loaduser routine loads the user dictionary if there is one to be loaded.
  168. ; First get some Heap to read the user dictionary into. We want
  169. ; get as much heap as there is available, minus some for the system.
  170. loaduser
  171.     lea    memsize(PC),a1    ; get initial space
  172.     move.l    (a1),d0
  173.     lea    nextdef+2(PC),a0    ; get top of nuc abs
  174.     sub.l    a0,d0    ; get user dict memsize acquired
  175.     add.l    a3,d0
  176. ;    move.l    d0,(a1)
  177.     asr.l    #2,d0           ; number of long words to clear
  178. clm    clr.l    (a0)+
  179.     dbra    d0,clm
  180.     lea    nextdef+2(PC),a0
  181.     lea    memptr(PC),a2
  182.     move.l    a0,(a2)    ; Save the memory pointer
  183. ; set up DP
  184.     suba.l    a3,a0    ; a0 has relative base of user dict
  185.     lea    initdp(PC),a2
  186.     move.l    a0,(a2)    ; Set default dp
  187.     andi.l    #$FFFFFF,(a2)    ; mask out hi byte  ????WHY
  188.     add.l    #sysvecSz,(a2)    ; bump dp past system vector table
  189. *
  190.     lea    userdp(PC),a2    ; Save pointer to dict. begin
  191.     move.l    a0,(a2)
  192.     andi.l    #$FFFFFF,(a2)
  193.     jsr    loadcom(PC)
  194.     rts
  195. ;
  196. ; Get the finder handle and see if there is file to be opened
  197. ;
  198. loadcom    movea.l    f.handle(a5),a0    ; Get finder handle
  199.     movea.l    (a0),a0    ; Dereference it
  200.     tst.w    (a0)    ; Check if open or print
  201.     beq    load010    ; ok to open
  202.     movea.l    #2,a0    ; error. we don't print
  203.     bra    loaderror
  204. ; The file is to be opened. See if there are any files to open.
  205. load010
  206.     tst.w    numfiles(a0)    ; any files to open?
  207.     bne    load020    ; at least one
  208.     movea.l    #1,a0    ; none. just the nucleus
  209.     bra    loaderror
  210. ; We have at least one file to be opened. Even if there are more than
  211. ; one at this point we are only going to open the first file picked.
  212. load020
  213.     adda.l    #4,a0    ; a0 points past the header
  214.     move.l    ftype(a0),a1    ; get filetype of the file
  215.     cmpa.l    #$434f4d20,a1    ; is it 'COM ' ?
  216.     bne    loaderror
  217.     lea    usefcb(PC),a1    ; load pointer to usefcb
  218.     lea    fname(a0),a2    ; load pointer to filename
  219.     move.l    a2,IoFileName(a1)    ; set file pointer in the fcb
  220.     lea    (a0),a2    ; load pointer to VRefNum
  221.     move.w    (a2),IoVRefNum(a1)    ; set VRefNum in the fcb
  222.     move.b    #1,IoPermssn(a1)    ; set i/o permission to readonly
  223.     move.l    a1,a0    ; Fcb in a0 for call
  224.     _open        ; Open the file
  225.     tst.w    IoResult(a0)    ; Check for errors
  226.     beq    load030    ; continue if ok
  227.     movea.l    IoResult(a0),a0    ; error code
  228.     bra    loaderror    ; Off to process errors
  229. ; Now get the file size so that we know how much to read in.
  230. load030    
  231.     movea.l    a1,a0    ; get the fcb back in a0
  232.     _getfileinfo    ; get info on the file
  233.     tst.w    IoResult(a0)    ; Check for errors
  234.     beq    load040    ; continue if ok
  235.     movea.l    IoResult(a0),a0    ; error code
  236.     bra    loaderror    ; Off to process errors
  237. load040
  238.     lea    nextdef+2(PC),a4    ; Get buffer addr
  239.     move.l    IoflLgLen(a0),d1    ; Get the logical length of file
  240.     movea.l    a1,a0    ; Fcb again
  241.     move.l    a4,iobuffer(a0)    ; Set buffer pointer for data in
  242.     move.l    #headlen,IoReqCount(a0)    ; Number of bytes to read
  243.     clr.l    IoPosMode(a0)    ; Read from beginning of file
  244.     clr.l    IoPosOffset(a0)    ; offset by 0
  245.     _read
  246.     tst.w    IoResult(a0)    ; Check for errors
  247.     beq    load060    ; continue if ok
  248.     movea.l    IoResult(a0),a0    ; error code
  249.     bra.s    loaderror    ; Off to process errors
  250. ; Initialize COLD load variables so that the user dictionary is included
  251. ; when the FORTH system is brought up.
  252. load060
  253.     lea    initdp(PC),a2
  254.     move.l    (a4),(a2)    ; Set dictionary pointer
  255.     lea    initfenc(PC),a2
  256.     move.l    ufence(a4),(a2)    ; Set fence pointer
  257.     lea    initvocl(PC),a2
  258.     move.l    uvocl(a4),(a2)    ; Set vocabulary link
  259.     lea    initLast(PC),a2
  260.     move.l    ulatest(a4),(a2)    ; Set latest NFA
  261. ; Now we can read the dictionary into the memory.
  262.     subi.l    #headlen,d1    ; Size of dictionary to read
  263.     move.l    d1,IoReqCount(a0)
  264.     clr.l    IoPosMode(a0)    ; Position to beginning of file
  265.     move.l    #headlen,IoPosOffset(a0)    ; Offset by headlen
  266.     _read        ; read the dictionary
  267.     tst.w    IoResult(a0)    ; Check for errors
  268.     beq    load070    ; continue if ok
  269.     movea.l    IoResult(a0),a0    ; error code
  270. loaderror
  271.     lea    userror(PC),a2
  272.     move.l    a0,(a2)    ; Save error code for cold
  273.     bra.s    load080
  274. load070
  275.     movea.l    a1,a0    ; fcb again
  276.     _close        ; Close the file
  277. load080
  278.     rts
  279. ; --------------------------------------
  280. ; area for calls to Toolbox, etc.
  281. ftwork    DEFS    20
  282. ftwork1    DC.L    0
  283. dsmsg    STR    "Parameter Stack:"
  284. rsmsg    STR    "Return Stack:   "
  285. msmsg    STR    "Methods Stack:  "
  286. emptymsg    STR    "  <empty>"
  287. pausemsg    STR    "Paused - <Space Bar> to continue>>>"
  288. bytesleft    STR    "Bytes Available: "
  289. hello    STR    "Macintosh Yerk Version 3.6.8"
  290. advise    STR    "This is only the nucleus. For the full system use Yerk.com or YerkFP.com."
  291.     ADJST
  292. tibbuf    DEFS    128    ; terminal input buffer
  293.     DATA    /0
  294.     DEFS    20    ; for numeric output
  295. padbuf    DEFS    256    ; text output buffer
  296. aregn    DATA    0    ; region handle for miscellany
  297.     ADJST
  298. ; Begin nucleus definitions
  299.     ADJST
  300. cld1    cfas    xcold,quit    ; do COLD word and enter Forth
  301. ; ====================================================
  302. ; Following are data areas that will be patched to look like objects
  303. ; after the Class/Object support code is in. Cfas will be patched to
  304. ; Class pointers.
  305. ; ====================================================
  306.     dcode    FWIND,x,origin,fwind ; link should be 0
  307. wRecord    
  308.     DEFS    windowsize    ; window record
  309.     DC.W    0,0,290,494    ; content rect boundaries
  310.     DC.W    8,8,340,510    ; grow rect boundaries
  311.     DC.W    -10000,-10000,10000,10000    ; drag rect boundaries
  312.     DC.W    1,1,1    ; growflg,dragflg, alive
  313.     DATA    nulw-origin    ; idle vector
  314.     DATA    cls-origin    ; deact vector
  315.     DATA    nulw-origin    ; content vector
  316.     DATA    nulw-origin    ; draw vector
  317.     DATA    nulw-origin    ; enact vector
  318.     DATA    nulw-origin    ; close vector
  319.     DC.W    $100    ; resid
  320.     DC.W    1    ; is this window scrollable?
  321.     DATA    0    ; special zoom cfa
  322. ; color stuff
  323.     DC.W    0    ; ?color
  324.     DATA    0    ; palette
  325.     DC.W    0    ; colorUsage
  326.     DC.W    256    ; #colors
  327. ;
  328.     dcode    FEVENT,x,fwind,fevent
  329. eventRec    DC.W    0    ; event record for GetNextEvent
  330. eventMsg    DC.L    0,0,0
  331. eventMod    DC.W    0
  332. eventmsk    DC.W    0
  333. eventSlp    DC.L    0
  334. mousRgn    DC.L    0
  335.     DC.W    4,23 ; header for event indexed area
  336.     DEFS    4*23
  337.     dcode    FFCB,x,fevent,ffcb
  338. ; ------------- Default FCB ------------
  339. useFCB    DEFS    144    ; Parm block for USING file
  340. useFname    DEFS    64    ; holds USING volume/file name string
  341. ; -----------------------------------------
  342. fcbl    EQU    *-useFCB    ; length of FCB
  343.     dcode    FPRECT,x,ffcb,fprect
  344. pRect    DC.W    0,0,294,470    ; Forth window rectangle
  345. ; =============================================================
  346.     dcode    ADOC,x,fprect,adoc
  347.     jsr    loadcom(PC)    ; load user dict according to fInfo
  348.     gonext
  349. ; system values
  350.     dval    S0,adoc,s0,0
  351.     dval    R0,S0,r0,0
  352.     dval    TIB,r0,tib,tibbuf-origin
  353.     dval    FENCE,tib,fence,0
  354.     dval    DP,fence,dp,0
  355.     dval    VOC-LINK,dp,vocl,0
  356.     dval    IN,vocl,in,0
  357.     dval    OUT,in,out,0
  358.     dval    CONTEXT,out,contxt,0
  359.     dval    CURRENT,contxt,currnt,0
  360.     dval    STATE,currnt,state,0
  361.     dval    CSTATE,state,cstate,0
  362.     dval    BASE,cstate,base,10
  363.     dval    DPL,base,dpl,0
  364.     dval    CSP,dpl,csp,0
  365.     dval    HLD,csp,hld,0
  366.     dval    WNEAVAIL,hld,wneavail,0    ; true if waitNextEvent in ROM
  367.     dval    HWPAVAIL,wneavail,hwpavail,0    ; true if flush cache
  368.     dval    HASGESTALT,hwpavail,hasGestalt,0    ; true if gestalt is in system
  369.     dval    HEAPTOP,hasGestalt,heapTop,0    ; top of heap filled at start
  370.     dval    HEAPBOT,heapTop,heapBot,0    ; bottom of heap filled at start
  371.     dval    UCASE,heapBot,ucase,1    ; flag for lowercase interpreting
  372.     dval    DOCS,ucase,docs,0    ; flag for document sources loaded
  373.     dval    LINE#,docs,line_,-1    ; line# in source file for documenation
  374.     dval    VERBOSE,line_,verbose,1    ; verbose compilation if true
  375.     dvect    VMODEL,verbose,vmodel,nulw    ; model for other vectors
  376.     dcon    FILEMK,vmodel,filemk,-300+origin    ; file mark constant
  377.     dcon    NEXT,filemk,next,donext
  378.     dcon    BEGIN-DP,next,bdp,userdp    ; use @
  379.     dcon    LOAD-ERROR,bdp,lerror,Userror    ; use @
  380.     dval    M0,lerror,m0,0
  381.     dcon    USE-FCB,m0,ufcb,useFCB    ; pushes addr of useFCB
  382.     dcon    MSIZE,ufcb,msiz,memsize    ; use @
  383.     dcon    BL,msiz,bl,$20+origin
  384.     dcon    TRUE,bl,true,1+origin
  385.     dcon    FALSE,true,false,0+origin
  386.     dsvect    KEYVEC,false,keyvec,4,key_    ; system vectors for I/O
  387.     dsvect    EMITVEC,keyvec,emitvec,8,emit_    ; console emit
  388.     dsvect    PEMITVEC,emitvec,pemitv,12,drop    ; printer emit
  389.     dsvect    TYPEVEC,pemitv,typevec,16,type_    ; console type
  390.     dsvect    PTYPEVEC,typevec,ptypev,20,drop2
  391.     dsvect    EXPVEC,ptypev,expvec,24,expect    ; expect
  392.     dsvect    ECHOVEC,expvec,echovec,28,emit_    ; echo for keys
  393.     dsvect    ABORTVEC,echovec,abvec,32,nulw    ; installable abo
  394.     dsvect    QUITVEC,abvec,quvec,36,nulw    ; installable startup vector
  395.     dsvect    UFIND,quvec,ufind,40,false    ; vector for user find
  396.     dsvect    OBJINIT,ufind,objini,44,nulw    ; init nucleus objs
  397.     dsvect    PCRVEC,objini,pcrvec,48,nulw    ; printer CR
  398.     dsvect    BLDVEC,pcrvec,bldvec,52,nulw    ; object builder
  399.     dsvect    CREATE,bldvec,kreate,56,creat_    ; create vector
  400.     dsvect    INTERPRET,kreate,interp,60,intrp_
  401.     dsvect    CRVEC,interp,crvec,64,cr_
  402.     dval    DISK-ERROR,crvec,dkerr,0
  403.     dval    CURS,dkerr,curs_,1    ; cursor on/off flag
  404. crsflag    EQU    *-4
  405.     dval    UCFLAG,curs_,ucflag,1    ; map to upper case
  406. ; ==============================================
  407.     dcode    BYE,x,ucflag,bye_
  408.     _exitToShell
  409. *
  410.     dcode    (CODEZONE),x,bye_,instal
  411.     lea    segStart(PC),a1    ; set CODE 2 resource size
  412.     movea.l    a1,a0
  413.     _recoverHandle    ; get a handle to appl *** need to unlock
  414.     move.l    (a7)+,d0    ; get ending rel addr
  415.     addq.l    #1,d0
  416.     andi.l    #-2,d0    ; ensure even
  417.     addi.l    #4,d0    ; add CODE pointer length
  418.     _SetHandleSize    ; increase the size
  419.     gonext
  420. *
  421.     dcode    FINFO,x,instal,finfo    ; point to finder handle
  422.     movea.l    f.handle(a5),a0
  423.     movea.l    (a0),a0    ; dereference
  424.     suba.l    a3,a0    ; make relative
  425.     move.l    a0,-(SP)    ; push dereferenced ptr
  426.     gonext
  427. *
  428.     dcode    .CUR,x,finfo,dotcur    ; draw a cursor
  429.     jsr    pcurs(PC)
  430.     gonext
  431. *
  432. pcurs    lea    crsflag(PC),a0    ; ( -- )
  433.     tst.l    (a0)    ; is cursor on or off?
  434.     beq    nocurs
  435.     pea    ftwork(PC)
  436.     _GetPenState    ; get the current pen state
  437.     move.w    #10,-(SP)    ; set xor mode
  438.     _PenMode
  439.     move.w    #7,-(SP)
  440.     clr.w    -(SP)
  441.     _Line
  442.     pea    ftwork(PC)
  443.     _SetPenState
  444. nocurs    rts
  445. *
  446.     dcode    (EMIT),x,dotcur,emit_
  447.     jsr    pcurs(PC)
  448.     addq.l    #2,SP    ; long -> integer
  449.     _DrawChar    ; expects Pascal CHAR on stack
  450.     jsr    pcurs(PC)
  451.     gonext
  452. *
  453.     dcode    (TYPE),x,emit_,type_
  454.     move.l    a3,d0
  455.     add.l    d0,4(SP)    ; make address absolute
  456.     clr.l    d0
  457.     move.w    2(SP),d0
  458.     swap    d0
  459.     move.l    d0,(SP)    ; zero start byte offset
  460.     _DrawText
  461.     jsr    pcurs(PC)
  462.     gonext
  463. *
  464.     dcode    NULW,x,type_,nulw    ; empty word for stubbing vectors
  465.     gonext
  466. *
  467.     dcode    WORD0,x,nulw,word0    ; push a word of 0 for function setup
  468.     clr.w    -(SP)
  469.     gonext
  470. *
  471.     dcode    PACK,x,word0,pack_    ; packs 2 longs into one
  472.     popd0        ; get y
  473.     addq.l    #2,SP
  474.     move.w    d0,-(SP)
  475.     gonext
  476. *
  477.     dcode    UNPACK,x,pack_,unpack
  478.     move.l    (sp),d0
  479.     move.w    d0,d1
  480.     ext.l    d1
  481.     move.l    d1,(SP)
  482.     asr.l    #8,d0
  483.     asr.l    #8,d0
  484.     move.l    d0,-(SP)
  485.     gonext
  486. *
  487.     dcode    I->L,x,unpack,itol    ; extend 16 bit stack cell to 32
  488.     move.w    (sp)+,d0
  489.     ext.l    d0
  490.     move.l    d0,-(SP)
  491.     gonext
  492. *
  493.     dcode    MAKEINT,x,itol,makint
  494.     addq.l    #2,SP    ; drop high-level word on stack
  495.     gonext
  496. *
  497.     dcode    NEWPTR,x,makint,xnewpt
  498.     popd0        ; get size for new block in d0
  499.     _NewPtrC    ; call the memory manager for a new block
  500.     sub.l    a3,a0    ; make ptr relative
  501.     move.l    a0,-(SP)    ; push ptr to nonrelocatable block
  502.     gonext
  503. *
  504.     dcode    NEWHANDLE,x,xnewpt,xnewha
  505.     popd0
  506.     _newHandC    ; special vers of _NewHandle
  507.     move.l    a0,-(SP)    ; push handle to relocatable block
  508.     gonext
  509. *
  510. *    ( hndl -- b)
  511.     dcode    ?ISHANDLE,x,xnewha,ishand
  512.     movea.l    (sp),a0    ; get hndl
  513.     move.l    a0,d0    ; make copy for compares
  514.     btst    #0,d0    ; not hndl if odd
  515.     bne.s    no
  516.     sub.l    a3,d0    ; into yerk mem space
  517.     cmp.l    heapBot9-origin(a3),d0    ; is hndl in prgm heap
  518.     blt.s    no    ; not hndl if < bot
  519.     cmp.l    heapTop9-origin(a3),d0
  520.     bgt.s    no    ; not hndl if > top
  521.     move.l    (a0),d0    ; get pointer
  522.     btst    #0,d0    ; not hndl if ptr odd
  523.     bne.s    no
  524.     move.l    d0,d1    ; save ptr copy
  525.     sub.l    a3,d1    ; into yerk mem space
  526.     cmp.l    heapBot9-origin(a3),d1    ; is ptr in prgm heap
  527.     blt.s    no    ; not if < bot
  528.     cmp.l    heapTop9-origin(a3),d1
  529.     bgt.s    no    ; not if > top
  530.     movea.l    a0,a1    ; copy hndl
  531.     movea.l    d0,a0    ; move ptr into a0
  532.     _recoverHandle
  533.     cmp.l    a0,a1    ; are hndls equal
  534.     bne.s    no
  535.     moveq    #1,d0    ; set true flag
  536.     bra.s    yes
  537. no    moveq    #0,d0    ; set false flag
  538. yes    move.l    d0,(sp)
  539.     gonext
  540. *
  541.     dcode    LOCK,x,ishand,xlock
  542.     movea.l    (SP),a0    ; get handle in a0
  543.     _hLock        ; mark the block locked
  544.     movea.l    (SP),a0
  545.     movea.l    (a0),a1    ; dereference the handle
  546.     suba.l    a3,a1    ; make it a Forth address based on a3
  547.     move.l    a1,(SP)    ; leave Forth address on stack
  548.     gonext
  549. *
  550.     dcode    KILLPTR,x,xlock,killpt    ; (relPtr -- )
  551.     movea.l    (SP)+,a0    ; get rel ptr in a0
  552.     add.l    a3,a0    ; make it absolute
  553.     _disposPtr    ; release it
  554.     gonext
  555. *
  556.     dcode    KILLHANDLE,x,killpt,killha
  557.     movea.l    (SP)+,a0    ; get handle
  558.     _disposHandle
  559.     gonext
  560. *    
  561.     dcode    GROWPTR,x,killha,groptr    ; ( bytes relptr --)
  562.     movea.l    (SP)+,a0    ; get rel ptr in a0
  563.     adda.l    a3,a0    ; make it absolute
  564.     move.l    a0,d4
  565.     _getPtrSize
  566.     add.l    (sp)+,d0    ; get new handle size
  567.     movea.l    d4,a0
  568.     _SetPtrSize    ; grow the block
  569.     gonext
  570. *
  571.     dcode    FREE,x,groPtr,free_    ; ( -- maxAvail )
  572.     _freeMem        ; what is max mem avail on heap?
  573.     pushd0        ; includes purging
  574.     gonext
  575. *
  576.     dcode    FREEBLK,x,free_,freblk
  577.     _maxmem        ; what is max mem avail on heap?
  578.     pushd0        ; includes purging
  579.     gonext
  580. *
  581.     dcode    >PTR,x,freblk,fetptr    ; ( handle    --- relptr )
  582.     movea.l    (SP),a0
  583.     move.l    (a0),d0    ; dereference a handle
  584.     tst.b    wneavail9+3-origin(a3)    ; if wne, then stripaddr
  585.     beq.s    noStrip
  586.     _stripAddress
  587.     bra.s    onPtr
  588. noStrip    and.l  lo3bytes,d0
  589. onPtr    sub.l   a3,d0
  590.     move.l    d0,(SP)    ; return its pointer
  591.     gonext
  592. *
  593.     dcode    GET-EVENT,x,fetptr,getevt
  594.     move.l    (SP)+,d7    ; get event mask into d7
  595.     swap    d7
  596. ev1    move.l    d7,-(SP)    ; make room for function return
  597.     lea    eventRec(PC),a0 ; ptr to event rec storage
  598.     move.l    a0,-(sp)
  599.     tst.b    wneavail9+3-origin(a3)    ; is waitnextevent here?
  600.     beq.s    usegne0
  601.     move.l    18(a0),-(sp)    ; get sleep value
  602.     move.l    22(a0),-(sp)    ; get mouse rgn
  603.     _waitNextEvt
  604.     bra.s    endevt0
  605. usegne0    _SystemTask    ; WNE not in ROM
  606.     _GetNextEvent
  607. endevt0    tst.w    (SP)+    ; should we handle this event?
  608.     beq    ev1    ; no - get another one
  609.     lea    eventRec(PC),a0
  610.     clr.l    d0
  611.     move.w    (a0),d0    ; pick up event type
  612.     beq.s    ev1    ; loop if null event
  613.     pushd0        ; push event type for caller
  614.     gonext
  615. *
  616.     dcode    ?EVENT,x,getevt,qevt
  617.     move.l    (SP)+,d7    ; get event mask into d0
  618.     swap    d7
  619.     move.l    d7,-(SP)    ; make room for function return
  620.     pea    eventRec(PC)    ; pointer to event rec storage
  621.     _EventAvail    ; call Toolbox
  622.     tst.w    (SP)+    ; should we handle this event?
  623.     beq    event1    ; no - return false
  624.     lea    eventRec(PC),a0
  625.     clr.l    d0
  626.     move.w    (a0),d0    ; pick up event type
  627.     beq    event1    ; loop if null event
  628. event2    move.l    #1,-(SP)    ; push true - event available
  629.     bra.s    event3
  630. event1    clr.l    -(SP)    ; push false - no event available
  631. event3    gonext
  632. *
  633.     dcode    GETEVENT,x,qevt,gevt    ; (  --- b )
  634.     clr.w    -(sp)    ; make room for function return
  635.     lea    eventRec(PC),a0
  636.     move.w    eventMsk-eventRec(a0),-(sp)    ; get event mask
  637.     move.l    a0,-(sp)
  638.     tst.b    wneavail9+3-origin(a3)    ; is waitnextevent here?
  639.     beq.s    usegne
  640.     move.l    18(a0),-(sp)    ; get sleep value
  641.     move.l    22(a0),-(sp)    ; get mouse rgn
  642.     _waitNextEvt
  643.     bra.s    endevt
  644. usegne    _SystemTask    ; WNE not in ROM
  645.     _GetNextEvent
  646. endevt    clr.w    -(SP)    ; make an integer a long
  647.     gonext
  648. *
  649.     dcode    @EVENT-MSG,x,gevt,ftemsg
  650.     lea    eventMsg(PC),a0
  651.     move.l    (a0),-(SP)    ; push contents of last event msg
  652.     gonext
  653. *
  654. ; Flush the caches on 030,040 machines
  655.     dcode    CFLUSH,x,ftemsg,cflush
  656.     tst.b    hwpavail9+3-origin(a3)
  657.     beq.s    noflush
  658.     moveq    #1,d0
  659.     _HWPriv
  660. noflush    gonext
  661. *
  662. ; FIND-WINDOW ( point -- region, wptr )
  663.     dcode    FIND-WINDOW,x,cflush,findw
  664.     popd0
  665.     clr.w    -(SP)
  666.     pushd0
  667.     pea    ftwork1(PC)
  668.     _FindWindow
  669.     clr.w    -(SP)
  670.     lea    ftwork1(PC),a0
  671.     move.l    (a0),d0
  672.     sub.l    a3,d0
  673.     pushd0
  674.     gonext
  675. *
  676.     dcode    INIT-TOOLS,x,findw,intool
  677.     _InitFonts
  678.     move.l    #$ffff,d0    ; every event rfl 10/89
  679.     _FlushEvents
  680.     _InitWindows
  681.     _TEInit
  682.     pea    EWRM(PC)    ; warm start for Resume button
  683. ;in deep shit
  684.     _InitDialogs
  685.     clr.l    -(SP)    ; for windowPtr return
  686.     move.w    #256,-(SP)    ; window ID
  687.     pea    wrecord(PC)
  688.     move.l    #-1,-(SP)    ; POINTER(-1) for front window
  689.     _GetNewWindow    ; get window resource def
  690.     _setPort        ; setPort(WindowPtr)
  691.     lea    wrecord(PC),a0
  692.     move.w    #9,txSize(a0)    ; window text size = 9
  693.     move.w    #4,txfont(a0)    ; window text font
  694.     lea    pRect(PC),a1
  695.     move.l    portRect(a0),(a1)
  696.     move.l    portRect+4(a0),4(a1)
  697.     clr.l    -(SP)
  698.     _NewRgn
  699.     lea    aRegn(PC),a0
  700.     move.l    (SP)+,(a0)    ; fill in region handle
  701.     clr.w    -(SP)
  702.     _TextMode    ; source copy text mode
  703.     _Initmenus
  704.     _InitCursor
  705.     move.w    #$9f,d0    ; check for trap availability
  706.     _getTrapAddress+$600
  707.     move.l    a0,d3    ; d3 = unimplemented trap addr
  708.     moveq  #$60,d0    ; check for WaitNextEvent
  709.     _getTrapAddress+$600
  710.     cmp.l    a0,d3    ; if <> waitnextevent is avail
  711.     sne    d0
  712.     move.b    d0,wneavail9+3-origin(a3)
  713.     move.l    #$198,d0    ; hwpriv trap addr
  714.     _getTrapAddress+$200
  715.     cmp.l    a0,d3    ; if <> hwpriv is avail
  716.     sne    d0
  717.     move.b    d0,hwpavail9+3-origin(a3)
  718.     move.l  #$1ad,d0    ; gestalt avail
  719.     _getTrapAddress+$200
  720.     cmp.l    a0,d3
  721.     sne    d0
  722.     move.b    d0,hasGestalt9+3-origin(a3)
  723.     move.l    heapend,d0
  724.     sub.l    a3,d0
  725.     move.l    d0,heapTop9-origin(a3)
  726.     move.l    applzone,d0
  727.     sub.l    a3,d0
  728.     move.l    d0,heapBot9-origin(a3)    
  729.     gonext
  730. *
  731.     dcode    HOME,x,intool,home
  732. dohome    move.l    #$f0008,d0
  733.     pushd0
  734.     _MoveTo        ; home
  735.     gonext
  736. *
  737.     dcode    CLS,x,home,cls
  738.     pea    pRect(PC)
  739.     _EraseRect
  740.     jmp    dohome(PC)
  741.     gonext
  742. *
  743.     dcode    SCROLL,x,cls,scroll    ; (dh dv --- )
  744.     popd0
  745.     popd1
  746.     pea    pRect(PC)
  747.     move.w    d1,-(SP)
  748.     move.w    d0,-(SP)
  749.     lea    aregn(PC),a0    ; get dummy region handle
  750.     move.l    (a0),-(SP)
  751.     _ScrollRect
  752.     gonext
  753. *
  754.     dcode    >ORIGIN,x,scroll,setorg
  755.     popd0
  756.     addq.l    #2,SP
  757.     move.w    d0,-(SP)
  758.     _SetOrigin
  759.     gonext
  760. *
  761.     dcode    LINE,x,setorg,xline    ; (dh dv ---)
  762.     popd0
  763.     addq.l    #2,SP
  764.     move.w    d0,-(SP)
  765.     _Line
  766.     gonext
  767. *
  768.     dcode    LINETO,x,xline,xline2    ; (x y --)
  769.     popd0
  770.     addq.l    #2,SP
  771.     move.w    d0,-(sp)
  772.     _LineTo
  773.     gonext
  774. *
  775.     dcode    LIT,x,xline2,lit ; build code header
  776.     move.l    (a4)+,-(SP)    ; push value at IP to stack
  777.     gonext
  778. *
  779.     dcode    WLIT,x,lit,wlit    ; build code header
  780.     move.w    (a4)+,-(SP)    ; push value at IP to stack
  781.     clr.w    -(SP)    ; extend to 32 bits
  782.     gonext
  783. *
  784.     dcode    WLITW,x,wlit,wlitw    ; build code header
  785.     move.w    (a4)+,-(sp)    ; push value at IP to stack
  786.     gonext    ; no extend
  787. *    
  788.     dcode    W@(IP),x,wlitw,wfetip
  789.     move.l    (a6),d0    ; get IP from 1 nest back
  790.     move.w    0(a3,d0.l),-(SP)    ; push the word
  791.     clr.w    -(SP)
  792.     add.l    #2,(a6)    ; increment old IP past word
  793.     gonext
  794. *
  795.     dcode    EXECUTE,x,wfetip,exec
  796.     move.l    (SP)+,d6    ; pop address to execute
  797.     move.l    0(a3,d6.l),d7    ; get contents of CFA
  798.     jmp    0(a3,d7.l)    ; execute the code
  799. *
  800.     dcode    TRAP,x,exec,trap_    ; execute passed-in Tool trap
  801.     popD0        ; get trap in d0
  802.     lea    trapword(PC),a0
  803.     move.w    d0,(a0)    ; store trap inline for execution
  804.     tst.b    hwpavail9+3-origin(a3)
  805.     beq.s    trapword    ; don't flush if hwpriv unavail
  806.     moveq    #1,d0    ; flush the cache on 030,040
  807.     _HWPriv
  808.     nop        ; so we don't get burned by prefetch
  809. trapword    DC.W    $A997    ; start with openresfile
  810.     gonext
  811. *
  812.     dcode    (GESTALT),x,trap_,gestalt_
  813.     moveq    #-1,d0
  814.     move.b    hasGestalt9+3-origin(a3),d1
  815.     beq        nogest
  816.     move.l    (sp),d0
  817.     clr.l    d1
  818.     move.l    d1,a0
  819.     _gestalt
  820.     move.l    a0,(sp)
  821.     ext.l    d0
  822.     bmi.s    nogest
  823.     moveq    #0,d0
  824.     bra.s    isgest
  825. nogest    addq    #4,sp
  826. isgest    move.l    d0,-(sp)
  827.     gonext
  828. *
  829.     dcode    GOTOXY,x,gestalt_,gotoxy
  830.     popd0        ; get Y in d0
  831.     addq.l    #2,SP    ; drop high-level word on stack
  832.     move.w    d0,-(SP)
  833.     _MoveTo        ; call Quickdraw to move pen
  834.     gonext
  835. *
  836.     dcode    BEEP,x,gotoxy,beep    ; ( dur -- )
  837.     addq.l    #2,sp
  838.     _sysbeep
  839.     gonext
  840. *
  841.     dcode    @XY,x,beep,fetxy    ; return X,Y pen location
  842.     pea    ftwork(PC)
  843.     _GetPen
  844.     lea    ftwork(PC),a0
  845.     clr.l    d0
  846.     move.w    2(a0),d0
  847.     pushd0        ; push X value
  848.     move.w    (a0),d0
  849.     pushd0        ; push Y value
  850.     gonext
  851. *
  852.     dcode    BRANCH,x,fetxy,bran
  853.     adda.l    (a4),a4    ; add relative offset to IP
  854.     gonext
  855. *
  856.     dcode    0BRANCH,x,bran,bran0
  857.     move.l    (SP)+,d0    ; pop data stack into d0
  858.     bne    br1    ; if non-0, ignore branch following
  859.     adda.l    (a4),a4    ; else take the branch
  860.     bra.s    br2
  861. br1    addq.l    #4,a4    ; next 32-bit cfa
  862. br2    gonext
  863. *
  864.     dcode    OFBR,x,bran0,ofbr    ; 0branch used by OF clauses
  865.     move.l    (SP)+,d0    ; pop data stack into d0
  866.     bne    ofbr1    ; if non-0, ignore branch
  867.     move.l    (a6),d1    ; get IP from return stack
  868.     move.l    0(a3,d1.l),d2
  869.     add.l    d2,(a6)    ; add to stacked IP
  870.     bra.s    ofbr2
  871. ofbr1    addq.l    #4,(a6)    ; next 32-bit cfa 1 nest back
  872.     addq.l    #4,SP    ; drop the value
  873. ofbr2    gonext
  874. *
  875.     dcode    FAKE,x,ofbr,fake_    ; use as a breakpoint with debugg
  876.     jmp    *(PC)
  877.     gonext
  878. *
  879.     dcode    (LOOP),x,fake_,loop_    ; (loop)
  880.     addq.l    #1,(a6)    ; bump index (long)
  881.     move.l    (a6),d0
  882.     cmp.l    4(a6),d0    ; compare index to limit
  883.     bge    xloop1
  884.     adda.l    (a4),a4    ; branch back to top of loop
  885.     gonext
  886. xloop1    addq.l    #8,a6    ; pop index,limit from return stack
  887.     addq.l    #4,a4
  888.     gonext
  889. *
  890.     dcode    (DO),x,loop_,do_    ; this DO terminates on limit=count
  891.     move.l    (SP),d0
  892.     cmp.l    4(SP),d0    ; does limit=count? if so, terminate
  893.     bne    doloop
  894.     adda.l    (a4),a4    ; forward jump IP
  895.     addq.l    #8,SP
  896.     gonext
  897. doloop    move.l    4(SP),-(a6)    ; limit val to Return stack
  898.     move.l    d0,-(a6)    ; start val
  899.     addq.l    #4,a4    ; skip the jump addr
  900.     addq.l    #8,SP
  901.     gonext
  902. *
  903.     dcode    (LOOP+),x,do_,ploop_
  904.     move.l    (SP)+,d0
  905.     bmi    xploop1
  906.     add.l    d0,(a6)
  907.     move.l    (a6),d0
  908.     cmp.l    4(a6),d0
  909.     bge    xploop2
  910.     adda.l    (a4),a4
  911.     bra.s    xploop3
  912. xploop1    add.l    D0,(a6)
  913.     move.l    (a6),d0
  914.     cmp.l    4(a6),d0
  915.     ble    xploop2
  916.     adda.l    (a4),a4
  917.     bra.s    xploop3
  918. xploop2    addq.l    #8,a6
  919.     addq.l    #4,a4
  920. xploop3    gonext
  921. *
  922.     dcode    I,x,ploop_,i
  923.     move.l    (a6),-(SP)
  924.     gonext
  925. *
  926.     dcode    I+,x,i,iplus    ; add I to top of stack
  927.     move.l    (a6),d0
  928.     add.l    d0,(SP)
  929.     gonext
  930. *
  931.     dcode    I-,x,iplus,iminus
  932.     move.l    (a6),d0
  933.     sub.l    d0,(SP)
  934.     gonext
  935. *
  936.     dcode    I@,x,iminus,ifetch    ; fetch from I as addr
  937.     move.l    (A6),d7
  938.     move.l    0(a3,d7.l),-(sp)
  939.     gonext
  940. *
  941.     dcode    I!,x,ifetch,istore
  942.     move.l    (A6),d7
  943.     move.l    (SP)+,0(a3,d7.l)
  944.     gonext
  945. *
  946.     dcode    IC@,x,istore,icfet
  947.     clr.l    d0
  948.     move.l    (a6),d7
  949.     move.b    0(a3,d7.l),d0
  950.     move.l    d0,-(SP)
  951.     gonext
  952. *
  953.     dcode    IC!,x,icfet,icstor
  954.     move.l    (A6),d7
  955.     move.l    (sp)+,d0
  956.     move.b    d0,0(a3,d7.l)
  957.     gonext
  958. *
  959.     dcode    J,x,icstor,j
  960.     move.l    8(a6),-(SP)
  961.     gonext
  962. *
  963.     dcode    DIGIT,x,j,digit
  964.     popd0
  965.     popd1
  966.     clr.l    d2
  967.     subi.l    #$30,d1
  968.     bmi    dig2
  969.     cmpi.l    #$0a,d1
  970.     bmi    dig1
  971.     subq.l    #7,d1
  972.     cmpi.l    #$0a,d1    ; to fix FIG bug that lets 58-64 pass
  973.     bmi    dig2
  974. dig1    cmp.l    d0,d1
  975.     bge    dig2
  976.     moveq    #1,d2
  977.     pushd1
  978. dig2    pushd2
  979.     gonext
  980. *
  981.     dcode    TRAVERSE,x,digit,traver
  982.     popd0
  983.     popd1
  984.     moveq    #$20,d2
  985.     lea    0(a3,d1.l),a0
  986.     tst.l    d0
  987.     bmi    trav1
  988.     move.b    (a0),d0
  989.     andi.l    #$1f,d0
  990.     adda.l    d0,a0
  991.     move.l    a0,d0
  992.     andi.l    #1,d0
  993.     suba.l    d0,a0
  994.     addq.l    #1,a0
  995.     bra.s    trav2
  996. trav1    tst.b    (a0)
  997.     bmi    trav2
  998.     subq.l    #1,d2    ; exit early if drags on
  999.     beq    trav2
  1000.     subq.l    #1,a0
  1001.     bra.s    trav1
  1002. trav2    suba.l    a3,a0
  1003.     move.l    a0,-(SP)
  1004.     gonext
  1005. *
  1006.     dcode    (FIND),x,traver,find_
  1007.     clr.l    d1
  1008.     move.l    (SP)+,d7
  1009.     lea    0(a3,d7.l),a0
  1010. pfind1    movea.l    a0,a2
  1011.     move.l    (SP),d7
  1012.     lea    0(a3,d7.l),a1
  1013.     move.b    (a2)+,d1
  1014.     andi.l    #$03f,d1
  1015.     cmp.b    (a1)+,d1
  1016.     bne    pfind3
  1017.     move.l    d1,d0
  1018. pfind2    cmpm.b    (a1)+,(a2)+
  1019.     bne    pfind3
  1020.     subq.l    #1,d0
  1021.     bne.s    pfind2
  1022.     bsr    odd
  1023.     addq.l    #8,a2
  1024.     suba.l    a3,a2
  1025.     move.l    a2,(SP)
  1026.     move.b    (a0),d0
  1027.     pushD0
  1028.     moveq    #1,d0
  1029.     bra.s    pfind4
  1030. pfind3    movea.l    a0,a2
  1031.     andi.w    #$1f,d1
  1032.     adda.l    d1,a2
  1033.     addq.l    #1,a2
  1034.     bsr    odd
  1035.     move.l    (a2),d7
  1036.     lea    0(a3,d7.l),a0
  1037.     tst.l    (a2)
  1038.     bne.s    pfind1
  1039.     addq.l    #4,SP
  1040.     clr.l    d0
  1041. pfind4    pushD0
  1042.     gonext
  1043. odd    move.l    a2,d0
  1044.     moveq    #1,d1
  1045.     and.l    d1,d0
  1046.     adda.l    d0,a2
  1047.     rts
  1048. *
  1049. ; ( SelPfa ^class -- f OR 1cfa t)
  1050.     dcode    ((FINDM)),x,find_,findm_
  1051.     move.l    (SP)+,d7    ; get relative ^class
  1052.     move.l    (SP)+,d0    ; get SelPfa to match
  1053.     move.l    0(a3,d7.l),d7    ; get contents of ^methods link field
  1054. findm0    lea    0(a3,d7.l),a1    ; get absolute ^methods dict nfa
  1055. findm1    cmp.w    (a1),d0    ; is this the method we want?
  1056.     beq    foundm    ; yes, we found the method
  1057.     move.l    2(a1),d7    ; link to previous method entry
  1058.     beq    notfndm    ; end of methods dict - not found
  1059.     bra.s    findm0
  1060. foundm    addi.l    #10,d7    ; point to 1cfa of method
  1061.     move.l    d7,-(SP)    ; push 1cfa to stack
  1062.     move.l    #1,-(SP)    ; true
  1063.     bra.s    fmexit    ; return to Forth
  1064. notFndm    clr.l    -(SP)
  1065. fmexit    gonext
  1066. *
  1067. *    ( addr delim -- addr n1 n2 n3 )
  1068.     dcode    ENCLOSE,x,findm_,enclos
  1069.     popd0        ; get delim in d0
  1070.     move.l    (SP),d7    ; addr in d7
  1071.     lea    0(a3,d7.l),a0    ; a0 has abs addr
  1072.     clr.l    d1
  1073. encGet    move.b    (a0)+,d2    ; get next byte in d2
  1074.     beq    encNull    ; null - unconditional exit
  1075.     cmpi.b    #9,d2    ; is char a Tab?
  1076.     bne    notab1
  1077.     move.b    #32,d2    ; map tabs to spaces
  1078. notab1    cmp.b    d0,d2    ; does first char = delim?
  1079.     bne    encNext    ; no
  1080.     addq.l    #1,d1    ; get another char
  1081.     bra.s    encGet
  1082. encNull    pushd1        ; found null- push idx at null
  1083.     addq.l    #1,d1    ; push idx of byte following
  1084.     pushd1
  1085.     bra.s    encl5    ; exit
  1086. encNext    pushd1        ; idx of first non-delim
  1087.     subq.l    #1,a0
  1088. encl3    move.b    (a0)+,d2
  1089.     beq    encl4
  1090.     cmp.b    #9,d2    ; is char a Tab?
  1091.     bne    notab2
  1092.     move.b    #32,d2    ; map tabs to spaces
  1093. notab2    cmp.b    d0,d2
  1094.     beq    encl4
  1095.     addq.l    #1,d1
  1096.     bra.s    encl3
  1097. encl4    move.l    d1,-(SP)
  1098.     tst.b    d2
  1099.     beq    encl5
  1100.     addq.l    #1,d1
  1101. encl5    pushd1        ; push unexamined idx and leave
  1102.     gonext
  1103. *
  1104.     dcode    (S=),x,enclos,sequ_    ; ( addr addr len -- b)
  1105.     popd0        ; get length of string comparison
  1106.     subq.l    #1,d0    ; setup counter for dbeq
  1107.     movea.l    (SP)+,a0
  1108.     movea.l    (SP)+,a1
  1109.     adda.l    a3,a0
  1110.     adda.l    a3,a1
  1111. dosequ    cmpm.b    (a0)+,(a1)+
  1112.     dbne    d0,dosequ
  1113.     cmp.w    #-1,d0
  1114.     beq    xsequ    ; counter was exhausted, so true
  1115.     clr.l    -(SP)    ; push false
  1116.     bra.s    nextsequ
  1117. xsequ    move.l    #1,-(SP)    ; push true
  1118. nextsequ    gonext
  1119. *
  1120.     dcode    CMOVE,x,sequ_,cmove
  1121. docmove    move.l    (SP)+,d0
  1122.     movea.l    (SP)+,a1
  1123.     movea.l    (SP)+,a0
  1124.     adda.l    a3,a0
  1125.     adda.l    a3,a1
  1126. cmov1    _BlockMove
  1127.     gonext
  1128. *
  1129. ; the somewhat dreaded multiply routines
  1130. mpy    move.l    (SP)+,-(a6)    ; save return address from jsr
  1131.     tst.w    (SP)    ; try short multiply first
  1132.     bne    mpy1
  1133.     tst.w    4(SP)    ; if both high words=0, we
  1134.     bne    mpy1    ; can do a short multiply
  1135.     popd0
  1136.     popd1
  1137.     mulu    d0,d1
  1138.     pushd1
  1139.     clr.l    d1
  1140.     pushd1
  1141.     move.l    (a6)+,-(SP)
  1142.     rts
  1143. mpy1    popd0        ; this is long multiply
  1144.     popd1
  1145.     moveq    #0,d2
  1146.     move.l    d2,-(SP)
  1147.     move.l    d2,-(SP)
  1148.     move.w    d1,d2
  1149.     mulu    d0,d2
  1150.     move.l    d2,4(SP)
  1151.     move.l    d1,d2
  1152.     swap    d2
  1153.     mulu    d0,d2
  1154.     add.l    d2,2(SP)
  1155.     swap    d0
  1156.     move.w    d1,d2
  1157.     mulu    d0,d2
  1158.     add.l    d2,2(SP)
  1159.     bcc    mpy2
  1160.     addq.w    #1,(SP)
  1161. mpy2    move.l    d1,d2
  1162.     swap    d2
  1163.     mulu    d0,d2
  1164.     add.l    d2,(SP)
  1165.     move.l    (a6)+,-(SP)
  1166.     rts
  1167. smpy    move.l    (SP)+,-(a6)
  1168.     tst.l    (SP)    ; signed multiply
  1169.     smi    d4
  1170.     bpl    smpy1
  1171.     neg.l    (SP)
  1172. smpy1    tst.l    4(SP)
  1173.     smi    d3
  1174.     bpl    smpy2
  1175.     neg.l    4(SP)
  1176. smpy2    eor.b    d3,d4
  1177.     bsr.s    mpy
  1178.     tst.b    d4
  1179.     beq    smpy3
  1180.     neg.l    4(SP)
  1181.     negx.l    (SP)
  1182. smpy3    move.l    (a6)+,-(SP)
  1183.     rts
  1184. xdiv    move.l    (SP)+,-(a6)
  1185.     tst.l    (SP)
  1186.     beq    div5
  1187.     tst.w    (SP)
  1188.     bne    longdiv
  1189.     tst.l    4(SP)
  1190.     bne    longdiv
  1191.     move.l    (SP)+,d2
  1192.     popd0
  1193.     popd1
  1194.     divu    d2,d1
  1195.     bvs    long1
  1196.     clr.l    d2
  1197.     move.w    d1,d2
  1198.     clr.w    d1
  1199.     swap    d1
  1200.     pushd1
  1201.     move.l    d2,-(SP)
  1202.     move.l    (a6)+,-(SP)
  1203.     rts
  1204. longdiv    move.l    (SP)+,d2    ; the dreaded long division
  1205.     popd0
  1206.     popd1
  1207. long1    moveq    #32,d3
  1208.     sub.l    d2,d0
  1209. div1    bmi    div2
  1210.     ori.l    #1,d1
  1211.     subq.w    #1,d3
  1212.     bmi    div3
  1213.     asl.l    #1,d1
  1214.     roxl.l    #1,d0
  1215.     sub.l    d2,d0
  1216.     bra.s    div1
  1217.     
  1218. div2    subq.w    #1,d3
  1219.     bmi    div3
  1220.     asl.l    #1,d1
  1221.     roxl.l    #1,d0
  1222.     add.l    d2,d0
  1223.     bra.s    div1
  1224. div3    tst.l    d0
  1225.     bpl    div4
  1226.     add.l    d2,d0
  1227. div4    pushd0
  1228.     pushd1
  1229.     move.l    (a6)+,-(SP)
  1230.     rts
  1231. div5    addq.l    #4,SP
  1232.     move.l    d2,4(SP)
  1233.     move.l    #$7fffffff,(SP)
  1234.     move.l    (a6)+,-(SP)
  1235.     rts
  1236. sdiv    move.l    (SP)+,-(a6)    ; save return address from jsr
  1237.     tst.l    (SP)    ; signed divide
  1238.     smi    d7    ; d4 change to d7  8-24-91
  1239.     bpl    sdiv1
  1240.     neg.l    (SP)
  1241. sdiv1    tst.l    4(SP)
  1242.     smi    d4    ; d7 changed to d4 to let rem sign = quotient sign
  1243.     bpl    sdiv2
  1244.     neg.l    8(SP)
  1245.     negx.l    4(SP)
  1246. sdiv2    eor.b    d4,d7
  1247.     bsr    xdiv
  1248.     tst.b    d7
  1249.     beq    sdiv3
  1250.     neg.l    (SP)
  1251. sdiv3    tst.b    d4
  1252.     beq    sdiv4
  1253.     neg.l    4(SP)
  1254. sdiv4    move.l    (a6)+,-(SP)
  1255.     rts
  1256. slmod    move.l    (SP)+,-(a6)
  1257.     moveq    #0,d1
  1258.     popd0
  1259.     tst.l    (SP)
  1260.     bpl    slmod1
  1261.     subq.l    #1,d1
  1262. slmod1    pushd1
  1263.     pushd0
  1264.     move.l    (a6)+,-(SP)
  1265.     bra.s    sdiv
  1266. *
  1267.     dcode    U*,x,cmove,ustar
  1268.     bsr    mpy
  1269.     gonext
  1270. *
  1271.     dcode    U/,x,ustar,uslash
  1272.     bsr    xdiv
  1273.     gonext
  1274. *
  1275.     dcode    M*,x,uslash,mstar
  1276.     bsr    smpy
  1277.     gonext
  1278. *
  1279.     dcode    M/,x,mstar,mslash
  1280.     bsr    sdiv
  1281.     gonext
  1282. *
  1283.     dcode    */,x,mslash,starsla
  1284.     move.l    (SP)+,-(a6)
  1285.     bsr    smpy
  1286.     move.l    (a6)+,-(SP)
  1287.     bsr    sdiv
  1288.     move.l    (SP)+,(SP)
  1289.     gonext
  1290. *
  1291.     dcode    */MOD,x,starsla,ssmod
  1292.     move.l    (SP)+,-(a6)
  1293.     bsr    smpy
  1294.     move.l    (a6)+,-(SP)
  1295.     bsr    sdiv
  1296.     gonext
  1297. *
  1298.     dcode    M/MOD,x,ssmod,msmod
  1299.     move.l    (SP)+,-(a6)
  1300.     moveq    #0,d0
  1301.     pushd0
  1302.     move.l    (a6),-(SP)
  1303.     bsr    xdiv
  1304.     move.l    (a6)+,d0
  1305.     move.l    (SP)+,-(a6)
  1306.     pushd0
  1307.     bsr    xdiv
  1308.     move.l    (a6)+,-(SP)
  1309.     gonext
  1310. *
  1311.     dcode    *,x,msmod,star    ; *
  1312.     bsr    smpy
  1313.     addq.l    #4,SP    ; drop top of stack
  1314.     gonext
  1315. *
  1316.     dcode    /,x,star,slash    ; /
  1317.     bsr    slmod
  1318.     move.l    (SP)+,(SP)
  1319.     gonext
  1320. *
  1321.     dcode    /MOD,x,slash,xslmod    ; /MOD
  1322.     bsr    slmod
  1323.     gonext
  1324. *
  1325.     dcode    MOD,x,xslmod,mod    ; MOD
  1326.     bsr    slmod
  1327.     addq.l    #4,SP
  1328.     gonext
  1329. *
  1330.     dcode    D>,x,mod,dgrt    ; D>
  1331.     moveq    #1,d0
  1332.     move.l    8(SP),d1
  1333.     cmp.l    (SP),d1
  1334.     bgt    dgrt1
  1335.     move.l    12(SP),d1
  1336.     cmp.l    4(SP),d1
  1337.     bgt    dgrt1
  1338.     moveq    #0,d0
  1339. dgrt1    adda.l    #16,SP
  1340.     pushd0
  1341.     gonext
  1342. *
  1343.     dcode    D<,x,dgrt,dless    ; D<
  1344.     moveq    #1,d0
  1345.     move.l    8(SP),d1
  1346.     cmp.l    (SP),d1
  1347.     blt    dless1
  1348.     move.l    12(SP),d1
  1349.     cmp.l    4(SP),d1
  1350.     blt    dless1
  1351.     moveq    #0,d0
  1352. dless1    adda.l    #16,SP
  1353.     pushd0
  1354.     gonext
  1355. *
  1356.     dcode    D=,x,dless,dequ    ; D=
  1357.     move.l    (SP),d1
  1358.     cmp.l    8(SP),d1
  1359.     seq    d0
  1360.     move.l    4(SP),d1
  1361.     cmp.l    12(SP),d1
  1362.     seq    d1
  1363.     adda.l    #16,SP
  1364.     and.l    d1,d0
  1365.     bra    setbyt
  1366.     gonext
  1367. *
  1368.     dcode    U<,x,dequ,uless
  1369.     cmp2
  1370.     scs    d0
  1371.     bra.s    setbyt
  1372. *
  1373.     dcode    U>,x,uless,ugrt
  1374.     cmp2
  1375.     scc    d0
  1376.     bra.s    setbyt
  1377. *
  1378.     dcode    <,x,ugrt,less    ; <
  1379.     cmp2
  1380.     slt    d0
  1381.     bra.s    setbyt
  1382. *
  1383.     dcode    >,x,less,grt    ; >
  1384.     cmp2
  1385.     sgt    d0
  1386.     bra.s    setbyt
  1387. *
  1388.     dcode    =,x,grt,equals    ; =
  1389.     cmp2
  1390.     seq    d0
  1391.     bra.s    setbyt
  1392. *
  1393.     dcode    <>,x,equals,nequals
  1394.     cmp2
  1395.     sne    d0
  1396.     bra.s    setbyt
  1397. *
  1398.     dcode    0=,x,nequals,zequ
  1399.     tst.l    (SP)+
  1400.     seq    d0
  1401.     bra.s    setbyt
  1402. *
  1403.     dcode    0<,x,zequ,zless
  1404.     tst.l    (SP)+
  1405.     smi    d0
  1406. setbyt    moveq    #1,d1
  1407.     and.l    d1,d0
  1408.     pushD0
  1409.     gonext
  1410. *
  1411.     dcode    0>,x,zless,zgrt
  1412.     tst.l    (SP)+
  1413.     sgt    d0
  1414.     bra.s    setbyt
  1415. *
  1416.     dcode    <=,x,zgrt,lesequ
  1417.     cmp2
  1418.     sle    d0
  1419.     bra.s    setbyt
  1420. *
  1421.     dcode    >=,x,lesequ,grtequ
  1422.     cmp2
  1423.     sge    d0
  1424.     bra.s    setbyt
  1425. *
  1426.     dcode    0!,x,grtequ,zstore    ; store 0 at addr
  1427.     move.l    (sp)+,d7
  1428.     clr.l    0(a3,d7.l)
  1429.     gonext
  1430. *
  1431.     dcode    0,x,zstore,pzer    ; short, fast 0 word
  1432.     clr.l    -(SP)
  1433.     gonext
  1434. *
  1435.     dcode    1,x,pzer,pone    ; short, fast 1 word
  1436.     move.l    #1,-(SP)
  1437.     gonext
  1438. *
  1439.     dcode    -1,x,pone,pmone    ; short, fast -1 word
  1440.     move.l    #-1,-(SP)
  1441.     gonext
  1442. *
  1443.     dcode    2,x,pmone,ptwo    ; short, fast 2 word
  1444.     move.l    #2,-(SP)
  1445.     gonext
  1446. *
  1447.     dcode    4,x,ptwo,pfour
  1448.     move.l    #4,-(SP)
  1449.     gonext
  1450. *
  1451.     dcode    AND,x,pfour,and_
  1452.     popD0
  1453.     and.l    d0,(SP)
  1454.     gonext
  1455. *
  1456.     dcode    LAND,x,and_,land_
  1457.     popd0
  1458.     tst.l    (SP)
  1459.     beq    land2
  1460.     move.l    #1,(SP)
  1461.     tst.l    d0
  1462.     beq    land1
  1463.     moveq    #1,d0
  1464. land1    and.l    d0,(SP)
  1465. land2    gonext
  1466. *
  1467.     dcode    OR,x,land_,or_
  1468.     popD0
  1469.     or.l    d0,(SP)
  1470.     gonext
  1471. *
  1472.     dcode    LOR,x,or_,lor_
  1473.     popd0
  1474.     tst.l    d0
  1475.     beq    lor1
  1476.     moveq    #1,d0
  1477. lor1    tst.l    (SP)
  1478.     beq    lor2
  1479.     move.l    #1,(SP)
  1480. lor2    or.l    d0,(SP)
  1481.     gonext
  1482. *
  1483.     dcode    XOR,x,lor_,xor
  1484.     popD0
  1485.     eor.l    d0,(SP)
  1486.     gonext
  1487. *
  1488.     dcode    LXOR,x,xor,lxor
  1489.     popd0
  1490.     tst.l    d0
  1491.     beq    lxor1
  1492.     moveq    #1,d0
  1493. lxor1    tst.l    (SP)
  1494.     beq    lxor2
  1495.     move.l    #1,(SP)
  1496. lxor2    eor.l    d0,(SP)
  1497.     gonext
  1498. *
  1499.     dcode    HERE,x,lxor,here
  1500.     move.l    #(dp9-origin),d7
  1501.     move.l    0(a3,d7.l),-(SP)
  1502.     gonext
  1503. *
  1504.     dcode    ALLOT,x,here,allot
  1505.     move.l    #(dp9-origin),d7
  1506.     popD0
  1507.     add.l    d0,0(a3,d7.l)    ; increment DP
  1508.     gonext
  1509. *
  1510.     dcode    SP@,x,allot,spfet
  1511.     move.l    SP,d0
  1512.     sub.l    a3,d0
  1513.     pushD0
  1514.     gonext
  1515. *
  1516.     dcode    SP!,x,spfet,spstor
  1517.     move.l    #(s09-origin),d7
  1518.     move.l    0(a3,d7.l),d7
  1519.     lea    0(a3,d7.l),SP    ; add a3 to it and store in SP
  1520.     gonext
  1521. *
  1522.     dcode    RP@,x,spstor,rpfet
  1523.     move.l    a6,d0
  1524.     sub.l    a3,d0
  1525.     pushD0
  1526.     gonext
  1527. *
  1528.     dcode    RP!,x,rpfet,rpstor
  1529.     move.l    #(r09-origin),d7
  1530.     move.l    0(a3,d7.l),d7
  1531.     lea    0(a3,d7.l),a6    ; add a3 to it and store in RP
  1532.     gonext
  1533. *
  1534.     dcode    MP!,x,rpstor,mpstor
  1535.     move.l    initmp(PC),d5
  1536.     add.l    a3,d5    ; get initmp and add a3 to it
  1537.     gonext
  1538. *
  1539.     dcode    MP@,x,mpstor,mpfet
  1540.     move.l    d5,d0
  1541.     sub.l    a3,d0
  1542.     pushD0
  1543.     gonext
  1544. *
  1545.     dcode    THEPORT,x,mpfet,port_
  1546.     move.l    (a5),a0    ; Point to QD globals
  1547.     move.l    (a0),d0    ; point to current grafport
  1548.     sub.l    a3,d0
  1549.     pushd0
  1550.     gonext
  1551. *
  1552.     dcode    (LCWORD),x,port_,lcword    ; doesn't map to upper ca
  1553.     popd0        ; d0=len to next word
  1554.     lea    in9(PC),a0
  1555.     add.l    d0,(a0)    ; bump IN
  1556.     popd0        ; d0=offs to end of parsed word
  1557.     popd1        ; d1=offs to beg of parsed word
  1558.     sub.w    d1,d0    ; d0=len this word
  1559.     lea    dp9(PC),a0
  1560.     movea.l    (a0),a0    ; a0=relative DP
  1561.     adda.l    a3,a0    ; a0=abs DP = HERE
  1562.     move.b    d0,(a0)    ; store len
  1563.     move.b    #32,1(a0,d0.l)    ; blank at end of word
  1564.     movea.l    (SP)+,a1    ; addr of string
  1565.     adda.l    a3,a1
  1566.     adda.l    d1,a1    ; a1=source address to move from
  1567. wMov    move.b    -1(a1,d0.w),0(a0,d0.w)    ; copy the string
  1568.     subq.l    #1,d0
  1569.     bne.s    wMov
  1570.     gonext
  1571. *
  1572.     dcode    (WORD),x,lcword,word_    ; fast code for WORD
  1573.     popd0        ; d0=len to next word
  1574.     lea    in9(PC),a0
  1575.     add.l    d0,(a0)    ; bump IN
  1576.     popd0        ; d0=offs to end of parsed word
  1577.     popd1        ; d1=offs to beg of parsed word
  1578.     sub.w    d1,d0    ; d0=len this word
  1579.     lea    dp9(PC),a0
  1580.     movea.l    (a0),a0    ; a0=relative DP
  1581.     adda.l    a3,a0    ; a0=abs DP = HERE
  1582.     move.b    d0,(a0)    ; store len
  1583.     move.b    #32,1(a0,d0.l)    ; blank at end of word
  1584.     movea.l    (SP)+,a1    ; addr of string
  1585.     adda.l    a3,a1
  1586.     adda.l    d1,a1    ; a1=source address to move from
  1587. wordMov    move.b    -1(a1,d0.w),0(a0,d0.w)    ; copy the string
  1588.     tst.b    ucase9+3-origin(a3)    ; is upper case flag on?
  1589.     beq.s    wordmov1
  1590.     cmpi.b    #96,0(a0,d0.w)
  1591.     ble    wordmov1    ; map to upper case
  1592.     cmpi.b    #123,0(a0,d0.w)
  1593.     bge    wordMov1
  1594.     subi.b    #32,0(a0,d0.w)
  1595. wordmov1    subq.l    #1,d0
  1596.     bne.s    wordMov
  1597.     gonext
  1598. *
  1599.     dcode    (DODO),x,word_,dodo    ; code for mcfa words
  1600. dodo1    move.w    -2(a3,d7.l),d0    ; pickup len to child's pfa
  1601.     add.l    d0,d6    ; advance wp
  1602.     move.l    d6,-(sp)    ; push pfa for do> code
  1603.     suba.l    a3,a4
  1604.     move.l    a4,-(a6)    ; save old IP on RP
  1605.     lea    10(a3,d7.l),a4    ; point IP to threaded code
  1606.     gonext
  1607. *
  1608. ; this code gets compiled before each piece of DO.. code (10 bytes long)
  1609.     dcode    DOJMP,x,dodo,dojmp
  1610.     move.l    #(dodo1-origin),d0
  1611.     jmp    0(a3,d0.l)
  1612. *
  1613. ; this code gets compiled into the front of each class definition
  1614. ; and is pointed to by the cfa of all objects
  1615.     dcode    DOOBJ,x,dojmp,doobj
  1616. obcode    addq.l    #4,d6    ; d6->pfa of object
  1617. dirObj    move.l    d6,-(SP)    ; push obj addr
  1618.     gonext
  1619. *
  1620. ; this is the code pointed to by the cfa of all classes
  1621.     dcode    DOCLASS,x,doobj,dclass
  1622.     addq.l    #4,d6
  1623.     move.l    d6,-(SP)    ; push ^class on stack
  1624.     move.l    #(bldvec-origin),d6    ; d6 has cfa of BLDVEC
  1625.     move.l    0(a3,d6.l),d7    ; d7 has code addr of BLDVEC
  1626.     jmp    0(a3,d7.l)    ; do it
  1627. *
  1628. ; runtime code for a message to a public object
  1629.     dcode    M0CFA,x,dclass,zcfa
  1630.     movea.l    d5,a2
  1631.     clr.l    d0
  1632.     clr.l    d4
  1633.     move.l    (SP)+,d3    ; get obj addr in d3
  1634.     move.b    8(a3,d6.l),d0    ; pickup #args for named stack
  1635.     beq    noArgs
  1636.     addq.l    #2,d6    ; skip extra word for #args in method
  1637.     move.l    d0,d1    ; save #args
  1638.     lsr.b    #4,d0    ; get #temps nybble
  1639.     beq    noLocs    ; no local vars
  1640.     move.l    d0,d4    ; accum total #cells in d4
  1641.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1642.     suba.l    d0,a2    ; allocate temp space
  1643. noLocs    andi.b    #$0f,d1    ; low nybble has #input parms
  1644.     beq    noIns    ; no input parms
  1645.     add.l    d1,d4
  1646. someArgs    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1647.     subq.w    #1,d1
  1648.     bne.s    someArgs    ; transfer all args from data stack
  1649. noIns    move.l    d4,d0
  1650. noArgs    move.l    d0,-(a2)    ; push #args to methods stack
  1651.     move.l    d3,-(a2)    ; d3 has base address of local data
  1652.     move.l    a2,d5
  1653.     suba.l    a3,a4    ; Perform colcode
  1654.     move.l    a4,-(a6)
  1655.     addq.l    #8,d6
  1656.     lea    0(a3,d6.l),a4
  1657.     gonext
  1658. *
  1659. ; runtime code for a message to a private ivar
  1660.     dcode    M1CFA,x,zcfa,onecfa
  1661.     move.l    d5,a2
  1662.     clr.l    d0
  1663.     clr.l    d4
  1664.     move.w    (a4)+,d0    ; get offset to ivar
  1665.     bge    notSelf    ; if negative, this is a Self reference
  1666.     clr.l    d0    ; if self, preserve base addr
  1667. notSelf    move.l    (a2),d2    ; get base address
  1668.     add.l    d0,d2    ; add offset to base address
  1669.     clr.w    d0
  1670.     move.b    4(a3,d6.l),d0    ; pickup #args for named stack
  1671.     beq    noArgs1
  1672.     addq.l    #2,d6    ; skip extra word for #args in method
  1673.     move.l    d0,d1    ; save #args
  1674.     lsr.b    #4,d0    ; get #temps nybble
  1675.     beq    nolocs1
  1676.     move.l    D0,D4    ; total #cells
  1677.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1678.     suba.l    d0,a2    ; allocate temp space
  1679. noLocs1    andi.b    #$0f,d1    ; low nybble has #input parms
  1680.     beq    noins1
  1681.     add.l    d1,d4    ; save #input parms
  1682. args1    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1683.     subq.w    #1,d1
  1684.     bne.s    args1    ; transfer all args from data stack
  1685. noins1    move.l    d4,d0
  1686. noArgs1    move.l    d0,-(a2)    ; push #args to methods stack
  1687.     move.l    d2,-(a2)    ; push offset+base to mstack
  1688. mNest    move.l    a2,d5
  1689.     suba.l    a3,a4    ; do colcode nest
  1690.     move.l    a4,-(a6)
  1691.     addq.l    #4,d6
  1692.     lea    0(a3,d6.l),a4
  1693.     gonext
  1694. *
  1695.     dcode    (;M),x,onecfa,semim_    ; this is the ;m definition
  1696.     addq.l    #8,d5    ; pop two entries from mstack
  1697.     movea.l    d5,a2
  1698.     move.l    -4(a2),d0    ; look at #args
  1699.     beq    noPop
  1700.     lsl.w    #2,d0    ; setup to add #args*4
  1701.     adda.l    d0,a2    ; pop #args
  1702.     move.l    a2,d5
  1703. noPop    move.l    (a6)+,d7
  1704.     lea    0(a3,d7.l),a4
  1705.     gonext
  1706. *
  1707.     dcode    ;S,x,semim_,semis    ; this is the ;S definition
  1708.     move.l    (a6)+,d7
  1709.     lea    0(a3,d7.l),a4
  1710.     gonext
  1711. *
  1712.     dcode    COLP,x,semis,pcolon    ; named stack colon code
  1713. pcolcode    move.l    d5,a2
  1714.     clr.l    d0
  1715.     clr.l    d4
  1716.     move.b    4(a3,d6.l),d0    ; pickup #args for named stack
  1717.     beq    noArgs3
  1718.     addq.l    #2,d6    ; skip extra word for #args in method
  1719.     move.l    d0,d1    ; save #args
  1720.     lsr.b    #4,d0    ; get #temps nybble
  1721.     beq    noLocs3    ; no local vars
  1722.     move.l    d0,d4    ; accum total #cells in d4
  1723.     lsl.b    #2,d0    ; compute #bytes = cells*4
  1724.     sub.l    d0,a2    ; allocate temp space
  1725. NoLocs3    andi.b    #$0f,D1    ; low nybble has #input parms
  1726.     beq    noIns3    ; no input parms
  1727.     add.l    d1,d4
  1728. Args3    move.l    (SP)+,-(a2)    ; pop data stack to methods stack
  1729.     subq.w    #1,d1
  1730.     bne.s    Args3    ; transfer all args from data stack
  1731. noIns3    move.l    d4,d0
  1732. noArgs3    move.l    d0,-(a2)    ; push #args to methods stack
  1733.     clr.l    -(a2)    ; waste the objaddr cell
  1734.     move.l    a2,d5    ;
  1735.     suba.l    a3,a4    ; Perform colcode
  1736.     move.l    a4,-(a6)
  1737.     addq.l    #4,d6
  1738.     lea    0(a3,d6.l),a4
  1739.     gonext
  1740. *
  1741.     dcode    (SEMIP),x,pcolon,semip    ; named stack denester co
  1742.     addq.l    #8,d5    ; pop two entries from mstack
  1743.     movea.l    d5,a2
  1744.     move.l    -4(a2),d0    ; look at #args
  1745.     beq    noPops1
  1746.     lsl.w    #2,d0    ; setup to add #args*4
  1747.     adda.l    d0,a2    ; pop #args
  1748.     move.l    a2,d5
  1749. nopops1    move.l    (a6)+,d7
  1750.     lea    0(a3,d7.l),a4
  1751.     gonext
  1752. *
  1753.     dcode    LEAVE,x,semip,leave
  1754.     move.l    (a6),4(a6)
  1755.     gonext
  1756. *
  1757.     dcode    >R,x,leave,toR
  1758.     move.l    (SP)+,-(a6)
  1759.     gonext
  1760. *
  1761.     dcode    R>,x,toR,rFrom
  1762.     move.l    (a6)+,-(SP)
  1763.     gonext
  1764. *
  1765.     dcode    R,x,rFrom,r
  1766.     move.l    (a6),-(SP)
  1767.     gonext
  1768. *
  1769.     dcode    PUSHM,x,r,mpush
  1770.     exg    d5,a2
  1771.     move.l    (SP)+,-(a2)
  1772.     exg    d5,a2
  1773.     gonext
  1774. *
  1775.     dcode    POPM,x,mpush,mpop
  1776.     exg    d5,a2
  1777.     move.l    (a2)+,-(SP)
  1778.     exg    d5,a2
  1779.     gonext
  1780. *
  1781.     dcode    COPYM,x,mpop,mcopy
  1782.     move.l    d5,a2
  1783.     move.l    (a2),-(SP)
  1784.     gonext
  1785. *
  1786.     dcode    EXGM,x,mcopy,mexg
  1787.     exg    d5,a2
  1788.     move.l    (SP),d0
  1789.     move.l    (a2),(SP)
  1790.     move.l    d0,(a2)
  1791.     gonext
  1792. *
  1793.     dcode    DUPM,x,mexg,mdup
  1794. dupm    exg    d5,a2
  1795.     move.l    (a2),-(a2)
  1796.     exg    d5,a2
  1797.     gonext
  1798. *
  1799.     dcode    ADDM,x,mdup,madd
  1800.     popd0
  1801. addmd0    exg    d5,a2    ; copied this from nucleus--suspect!
  1802.     add.l    d0,(a2)
  1803.     exg    d5,a2
  1804.     gonext
  1805. *
  1806.     dcode    DROPM,x,madd,mdrop
  1807.     exg    d5,a2    ; *** popmd0
  1808.     move.l    (a2)+,d0
  1809.     exg    d5,a2
  1810.     gonext
  1811. *
  1812.     dcode    MP0,x,mdrop,mp0    ; mstack picks for named parms
  1813.     move.l    d5,a2
  1814.     move.l    8(a2),-(SP)    ; push parm to data stack
  1815.     gonext
  1816. *
  1817.     dcode    MP1,x,mp0,mp1    ; mstack picks for named parms
  1818.     move.l    d5,a2
  1819.     move.l    12(a2),-(SP)    ; push parm to data stack
  1820.     gonext
  1821. *
  1822.     dcode    MP2,x,mp1,mp2    ; mstack picks for named parms
  1823.     move.l    d5,a2
  1824.     move.l    16(a2),-(SP)    ; push parm to data stack
  1825.     gonext
  1826. *
  1827.     dcode    MP3,x,mp2,mp3    ; mstack picks for named parms
  1828.     move.l    d5,a2
  1829.     move.l    20(a2),-(SP)    ; push parm to data stack
  1830.     gonext
  1831. *
  1832.     dcode    MP4,x,mp3,mp4    ; mstack picks for named parms
  1833.     move.l    d5,a2
  1834.     move.l    24(a2),-(SP)    ; push parm to data stack
  1835.     gonext
  1836. *
  1837.     dcode    MP5,x,mp4,mp5    ; mstack picks for named parms
  1838.     move.l    d5,a2
  1839.     move.l    28(a2),-(SP)    ; push parm to data stack
  1840.     gonext
  1841. *
  1842.     dcode    MS0,x,mp5,ms0    ; mstack stores for named parms
  1843.     move.l    d5,a2
  1844.     move.l    (SP)+,8(a2)    ; replace parm val with top of stack
  1845.     gonext
  1846. *
  1847.     dcode    MS1,x,ms0,ms1    ; mstack stores for named parms
  1848.     move.l    d5,a2
  1849.     move.l    (SP)+,12(a2)    ; replace parm val with top of stack
  1850.     gonext
  1851. *
  1852.     dcode    MS2,x,ms1,ms2    ; mstack stores for named parms
  1853.     move.l    d5,a2
  1854.     move.l    (SP)+,16(a2)    ; replace parm val with top of stack
  1855.     gonext
  1856. *
  1857.     dcode    MS3,x,ms2,ms3    ; mstack stores for named parms
  1858.     move.l    d5,a2
  1859.     move.l    (SP)+,20(a2)    ; replace parm val with top of stack
  1860.     gonext
  1861. *
  1862.     dcode    MS4,x,ms3,ms4    ; mstack stores for named parms
  1863.     move.l    d5,a2
  1864.     move.l    (SP)+,24(a2)    ; replace parm val with top of stack
  1865.     gonext
  1866. *
  1867.     dcode    MS5,x,ms4,ms5    ; mstack stores for named parms
  1868.     move.l    d5,a2
  1869.     move.l    (SP)+,28(a2)    ; replace parm val with top of stack
  1870.     gonext
  1871. *
  1872.     dcode    (++>),x,ms5,minc    ; increment named parm
  1873.     move.l    d5,a2
  1874.     move.w    (a4)+,d0    ; get element offset
  1875.     move.l    (sp)+,d1    ; get increment value
  1876.     add.l    d1,0(a2,d0.w)    ; increment the cell
  1877.     gonext
  1878. *
  1879.     dcode    (EX>),x,minc,mdo    ; execute a procedural arg
  1880.     move.l    d5,a2
  1881.     move.w    (a4)+,d0    ; get offset to named parm
  1882.     move.l    0(a2,d0.w),d6    ; get the cfa
  1883.     move.l    0(a3,d6.l),d7    ; get the code
  1884.     jmp    0(a3,d7.l)
  1885. *
  1886.     dcode    +,x,mdo,plus
  1887.     popD0
  1888.     add.l    d0,(SP)
  1889.     gonext
  1890. *
  1891.     dcode    -,x,plus,subt
  1892.     popD0
  1893.     sub.l    d0,(SP)
  1894.     gonext
  1895. *
  1896.     dcode    MAX,x,subt,max
  1897.     popD0
  1898.     cmp.l    (SP),d0
  1899.     blt    maxq
  1900.     move.l    d0,(SP)
  1901. maxq    gonext
  1902. *
  1903.     dcode    MIN,x,max,min
  1904.     popD0
  1905.     cmp.l    (SP),d0
  1906.     bgt    minq
  1907.     move.l    d0,(SP)
  1908. minq    gonext
  1909. *
  1910.     dcode    NEGATE,x,min,minus
  1911. mins1    neg.l    (SP)
  1912.     gonext
  1913. *
  1914.     dcode    DNEGATE,x,minus,dminus
  1915. dmins1    neg.l    4(SP)
  1916.     negx.l    (SP)
  1917.     gonext
  1918. *
  1919.     dcode    CFA,x,dminus,cfa
  1920.     subq.l    #4,(SP)
  1921.     gonext
  1922. *
  1923.     dcode    +-,x,cfa,plmin
  1924.     tst.l    (SP)+
  1925.     bmi.s    mins1
  1926.     gonext
  1927. *
  1928.     dcode    ABS,x,plmin,abs
  1929.     tst.l    (SP)
  1930.     bmi.s    mins1
  1931.     gonext
  1932. *
  1933.     dcode    DABS,x,abs,dabs
  1934.     tst.l    (SP)
  1935.     bmi.s    dmins1
  1936.     gonext
  1937. *
  1938.     dcode    S->D,x,dabs,sToD
  1939.     moveq    #0,d0
  1940.     tst.l    (SP)
  1941.     bpl    GOHERE
  1942.     subq.l    #1,d0
  1943. GOHERE    pushd0
  1944.     gonext
  1945. *
  1946.     dcode    OVER,x,sToD,over
  1947.     move.l    4(SP),-(SP)
  1948.     gonext
  1949. *
  1950.     dcode    2OVER,x,over,over2
  1951.     move.l    12(SP),-(SP)
  1952.     move.l    12(SP),-(SP)
  1953.     gonext
  1954. *
  1955.     dcode    DROP,x,over2,drop
  1956.     addq.l    #4,SP
  1957.     gonext
  1958. *
  1959.     dcode    2DROP,x,drop,drop2
  1960.     addq.l    #8,SP
  1961.     gonext
  1962. *
  1963.     dcode    SWAP,x,drop2,swap_
  1964.     popD0
  1965.     move.l    (SP),d1
  1966.     move.l    d0,(SP)
  1967.     pushD1
  1968.     gonext
  1969. *
  1970.     dcode    2SWAP,x,swap_,swap2
  1971.     popD0
  1972.     popD1
  1973.     move.l    (SP)+,d3
  1974.     move.l    (SP),d4
  1975.     move.l    d1,(SP)
  1976.     move.l    d0,-(SP)
  1977.     move.l    d4,-(SP)
  1978.     move.l    d3,-(SP)
  1979.     gonext
  1980. *
  1981.     dcode    DUP,x,swap2,dup
  1982.     move.l    (SP),-(SP)
  1983.     gonext
  1984. *
  1985.     dcode    2DUP,x,dup,dup2
  1986.     move.l    4(SP),-(SP)
  1987.     move.l    4(SP),-(SP)
  1988.     gonext
  1989. *
  1990.     dcode    -DUP,x,dup2,mindup
  1991.     tst.l    (SP)
  1992.     beq    ddup
  1993.     move.l    (SP),-(SP)
  1994. ddup    gonext
  1995. *
  1996.     dcode    +!,x,mindup,plstor
  1997.     move.l    (SP)+,d7
  1998.     popD0
  1999.     add.l    d0,0(a3,d7.l)
  2000.     gonext
  2001. *
  2002.     dcode    TOGGLE,x,plstor,toggle
  2003.     popD0
  2004.     move.l    (SP)+,d7
  2005.     eor.b    d0,0(a3,d7.l)
  2006.     gonext
  2007. *
  2008.     dcode    W@,x,toggle,wfetch    ; this is a 16-bit fetch
  2009.     clr.l    d0
  2010.     move.l    (SP),d7
  2011.     move.w    0(a3,d7.l),d0
  2012.     move.l    d0,(SP)
  2013.     gonext
  2014. *
  2015.     dcode    @,x,wfetch,fetch    ; this is a 32-bit fetch
  2016.     move.l    (SP),d7
  2017.     move.l    0(a3,d7.l),(SP)
  2018.     gonext
  2019. *
  2020.     dcode    C@,x,fetch,cfetch
  2021.     clr.l    d0
  2022.     move.l    (SP),d7
  2023.     move.b    0(a3,d7.l),d0
  2024.     move.l    d0,(SP)
  2025.     gonext
  2026. *
  2027.     dcode    MW@,x,cfetch,mwfetch    ; 16-bit fetch from mstack addr
  2028.     move.l    d5,a2
  2029.     clr.l    d0
  2030.     move.l    (a2),d7
  2031.     move.w    0(a3,d7.l),d0
  2032.     ext.l    d0    ; sign-extend
  2033.     move.l    d0,-(SP)
  2034.     gonext
  2035. *
  2036.     dcode    M@,x,mwfetch,mfetch    ; this is a 32-bit fetch
  2037.     move.l    d5,a2
  2038.     move.l    (a2),d7
  2039.     move.l    0(a3,d7.l),-(SP)
  2040.     gonext
  2041. *
  2042.     dcode    2@,x,mfetch,fetch2    ; ( double word fetch )
  2043.     move.l    (SP),d7
  2044.     lea    0(a3,d7.l),a0
  2045.     move.l    (a0)+,-(sp)
  2046.     move.l    (a0),4(SP)
  2047.     gonext
  2048. *
  2049.     dcode    W!,x,fetch2,wstore    ; 16-bit store
  2050.     move.l    (SP)+,d7    ; address is relative to a3
  2051.     popD0        ; d0 has value
  2052.     move.w    d0,0(a3,d7.l)
  2053.     gonext
  2054. *
  2055.     dcode    W+!,x,wstore,wpstore    ; 16-bit plus store
  2056.     move.l    (SP)+,d7
  2057.     popD0
  2058.     add.w    d0,0(a3,d7.l)
  2059.     gonext
  2060. *
  2061.     dcode    !,x,wpstore,store    ; 32-bit store
  2062.     move.l    (SP)+,d7    ; address is relative to a3
  2063.     popD0        ; d0 has value
  2064.     move.l    d0,0(a3,d7.l)
  2065.     gonext
  2066. *
  2067.     dcode    C!,x,store,cstore
  2068.     move.l    (SP)+,d7
  2069.     popD0
  2070.     move.b    d0,0(a3,d7.l)
  2071.     gonext
  2072. *
  2073.     dcode    C+!,x,cstore,cpstore    ; 8 bit plus store
  2074.     move.l    (SP)+,d7
  2075.     popD0
  2076.     add.b    d0,0(a3,d7.l)
  2077.     gonext
  2078. *
  2079.     dcode    MW!,x,cpstore,mwstore    ; 16-bit store to addr on mstack
  2080.     move.l    d5,a2
  2081.     move.l    (a2),d7    ; address is relative to a3
  2082.     popD0        ; d0 has value
  2083.     move.w    d0,0(a3,d7.l)
  2084.     gonext
  2085. *
  2086.     dcode    M!,x,mwstore,mstore    ; 32-bit store to addr on mstack
  2087.     move.l    d5,a2
  2088.     move.l    (a2),d7    ; address is relative to a3
  2089.     popD0        ; d0 has value
  2090.     move.l    d0,0(a3,d7.l)
  2091.     gonext
  2092. *
  2093.     dcode    2!,x,mstore,store2    ; ( double word store )
  2094.     move.l    (SP)+,d7
  2095.     lea    0(a3,d7.l),a0
  2096.     move.l    (SP)+,(a0)+
  2097.     move.l    (SP)+,(a0)
  2098.     gonext
  2099. *
  2100.     dcode    D+,x,store2,dplus    ; 64-bit add
  2101.     popd0
  2102.     popd1
  2103.     move.l    (SP)+,d2
  2104.     move.l    (sp)+,d3
  2105.     add.l    d1,d3
  2106.     addx.l    d0,d2
  2107.     move.l    d3,-(SP)
  2108.     move.l    d2,-(SP)
  2109.     gonext
  2110. *
  2111.     dcode    1+,x,dplus,plus1
  2112.     addq.l    #1,(SP)
  2113.     gonext
  2114. *
  2115.     dcode    2+,x,plus1,plus2
  2116.     addq.l    #2,(SP)
  2117.     gonext
  2118. *
  2119.     dcode    3+,x,plus2,plus3
  2120.     addq.l    #3,(SP)
  2121.     gonext
  2122. *
  2123.     dcode    4+,x,plus3,plus4
  2124.     addq.l    #4,(SP)
  2125.     gonext
  2126. *
  2127.     dcode    8+,x,plus4,plus8
  2128.     addq.l    #8,(SP)
  2129.     gonext
  2130. *
  2131.     dcode    1-,x,plus8,min1
  2132.     subq.l    #1,(SP)
  2133.     gonext
  2134. *
  2135.     dcode    2-,x,min1,min2
  2136.     subq.l    #2,(SP)
  2137.     gonext
  2138. *
  2139.     dcode    4-,x,min2,min4
  2140.     subq.l    #4,(SP)
  2141.     gonext
  2142. *
  2143.     dcode    8-,x,min4,min8
  2144.     subq.l    #8,(SP)
  2145.     gonext
  2146. *
  2147.     dcode    2*,x,min8,times2
  2148.     move.l    (SP),d0
  2149.     asl.l    #1,d0
  2150.     move.l    d0,(SP)
  2151.     gonext
  2152. *
  2153.     dcode    4*,x,times2,times4
  2154.     move.l    (SP),d0
  2155.     asl.l    #2,d0
  2156.     move.l    d0,(SP)
  2157.     gonext
  2158. *
  2159.     dcode    8*,x,times4,times8
  2160.     move.l    (SP),d0
  2161.     asl.l    #3,d0
  2162.     move.l    d0,(SP)
  2163.     gonext
  2164. *
  2165.     dcode    2/,x,times8,xdiv2
  2166.     move.l    (SP),d0
  2167.     asr.l    #1,d0
  2168.     move.l    d0,(SP)
  2169.     gonext
  2170. *
  2171. ; ^elem expects base addr on mstack, and an index on pstack
  2172.     dcode    (^ELEM),x,xdiv2,pelem    ; return address of array eleme
  2173.     move.l    d5,a2    ; pickup base address on mstack
  2174.     move.l    (a2),d7    ; base of object in d7
  2175.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2176.     clr.l    d1
  2177.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2178.     add.l    d1,d7    ; d7 points to idx hdr
  2179.     move.w    0(a3,d7.l),d1    ; fetch width word from header
  2180.     mulu    2(SP),d1    ; multiply index * width
  2181.     add.l    d1,d7    ; add to base address
  2182.     addq.l    #4,d7    ; skip the header
  2183.     move.l    d7,(SP)    ; leave on data stack
  2184.     gonext
  2185. *
  2186.     dcode    IDXBASE,x,pelem,idxbas    ; idx addr of indexed object
  2187.     move.l    d5,a2    ; pickup base address on mstack
  2188.     move.l    (a2),d7    ; base of object in d7
  2189.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2190.     clr.l    d1
  2191.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2192.     add.l    d1,d7    ; d7 points to idx hdr
  2193.     addq.l    #4,d7    ; skip the idx hdr
  2194.     move.l    d7,-(SP)    ; leave the ^ixdata
  2195.     gonext
  2196. *
  2197.     dcode    LIMIT,x,idxbas,limit    ; limit of indexed object
  2198.     move.l    d5,a2    ; pickup base address on mstack
  2199.     move.l    (a2),d7    ; base of object in d7
  2200.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2201.     clr.l    d1
  2202.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2203.     add.l    d1,d7    ; d7 points to idx hdr
  2204.     move.w    2(a3,d7.l),-(SP)    ; leave the limit
  2205.     clr.w    -(SP)
  2206.     gonext
  2207. *
  2208.     dcode    RANGE?,x,limit,qrange    ; index out of range?
  2209.     move.l    d5,a2    ; pickup base address on mstack
  2210.     move.l    (a2),d7    ; base of object in d7
  2211.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2212.     clr.l    d1
  2213.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2214.     add.l    d1,d7    ; d7 points to idx hdr
  2215.     clr.l    d0
  2216.     move.w    2(a3,d7.l),d0    ; get the limit
  2217.     cmp.l    (SP),d0    ; is limit > index?
  2218.     sle    d1    ; true if out of range
  2219.     neg.b    d1    ; forth boolean
  2220.     move.l    d1,-(SP)
  2221.     gonext
  2222. *
  2223. ; at1 treats value as unsigned
  2224.     dcode    AT1,x,qrange,at1    ; at opt for byte elements
  2225.     move.l    d5,a2    ; pickup base address on mstack
  2226.     move.l    (a2),d7    ; base of object in d7
  2227.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2228.     clr.l    d1
  2229.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2230.     add.l    d1,d7    ; d7 points to idx hdr
  2231.     add.l    (SP),d7    ; add the index
  2232.     clr.l    d0
  2233.     move.b    4(a3,d7.l),d0    ; fetch addr+4 (for idx hdr)
  2234.     move.l    d0,(SP)
  2235.     gonext
  2236. *
  2237.     dcode    AT2,x,at1,at2    ; at opt for byte elements
  2238.     move.l    d5,a2    ; pickup base address on mstack
  2239.     move.l    (a2),d7    ; base of object in d7
  2240.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2241.     clr.l    d1
  2242.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2243.     add.l    d1,d7    ; d7 points to idx hdr
  2244.     move.l    (SP),d0    ; get the index
  2245.     lsl.w    #1,d0    ; index * 2
  2246.     add.l    d0,d7    ; add the index
  2247.     move.w    4(a3,d7.l),d1    ; fetch addr+4 (for idx hdr)
  2248.     ext.l    d1    ; sign extend
  2249.     move.l    d1,(sp)
  2250.     gonext
  2251. *
  2252.     dcode    AT4,x,at2,at4    ; at opt for long elements
  2253.     move.l    d5,a2    ; pickup base address on mstack
  2254.     move.l    (a2),d7    ; base of object in d7
  2255.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2256.     clr.l    d1
  2257.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2258.     add.l    d1,d7    ; d7 points to idx hdr
  2259.     move.l    (SP),d0    ; get the index
  2260.     lsl.w    #2,d0    ; index * 4
  2261.     add.l    d0,d7    ; add the index
  2262.     move.l    4(a3,d7.l),(SP)    ; fetch addr+4 (for idx hdr)
  2263.     gonext
  2264. *
  2265.     dcode    TO1,x,at4,to1    ; To opt for byte elements
  2266.     move.l    d5,a2    ; pickup base address on mstack
  2267.     move.l    (a2),d7    ; base of object in d7
  2268.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2269.     clr.l    d1
  2270.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2271.     add.l    d1,d7    ; d7 points to idx hdr
  2272.     add.l    (SP)+,d7    ; add the index
  2273.     move.l    (SP)+,d0
  2274.     move.b    d0,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2275.     gonext
  2276. *
  2277.     dcode    TO2,x,to1,to2    ; To opt for byte elements
  2278.     move.l    d5,a2    ; pickup base address on mstack
  2279.     move.l    (a2),d7    ; base of object in d7
  2280.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2281.     clr.l    d1
  2282.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2283.     add.l    d1,d7    ; d7 points to idx hdr
  2284.     move.l    (SP)+,d0    ; get the index
  2285.     lsl.w    #1,d0    ; index * 2
  2286.     add.l    d0,d7    ; add the index
  2287.     move.l    (sp)+,d1
  2288.     move.w    d1,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2289.     gonext
  2290. *
  2291.     dcode    TO4,x,to2,to4    ; to opt for long elements
  2292.     move.l    d5,a2    ; pickup base address on mstack
  2293.     move.l    (a2),d7    ; base of object in d7
  2294.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2295.     clr.l    d1
  2296.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2297.     add.l    d1,d7    ; d7 points to idx hdr
  2298.     move.l    (SP)+,d0    ; get the index
  2299.     lsl.w    #2,d0    ; index * 4
  2300.     add.l    d0,d7    ; add the index
  2301.     move.l    (SP)+,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  2302.     gonext
  2303. *
  2304.     dcode    ++4,x,to4,inc4    ; inc opt for long elements
  2305.     move.l    d5,a2    ; pickup base address on mstack
  2306.     move.l    (a2),d7    ; base of object in d7
  2307.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2308.     clr.l    d1
  2309.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2310.     add.l    d1,d7    ; d7 points to idx hdr
  2311.     move.l    (SP)+,d0    ; get the index
  2312.     lsl.w    #2,d0    ; index * 4
  2313.     add.l    d0,d7    ; add the index
  2314.     move.l    (SP)+,d1    ; get increment
  2315.     add.l    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2316.     gonext
  2317. *
  2318.     dcode    ++2,x,inc4,inc2    ; inc opt for word elements
  2319.     move.l    d5,a2    ; pickup base address on mstack
  2320.     move.l    (a2),d7    ; base of object in d7
  2321.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2322.     clr.l    d1
  2323.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2324.     add.l    d1,d7    ; d7 points to idx hdr
  2325.     move.l    (SP)+,d0    ; get the index
  2326.     lsl.w    #1,d0    ; index * 4
  2327.     add.l    d0,d7    ; add the index
  2328.     move.l    (SP)+,d1    ; get increment
  2329.     add.w    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2330.     gonext
  2331. *
  2332.     dcode    ++1,x,inc2,inc1    ; inc opt for byte elements
  2333.     move.l    d5,a2    ; pickup base address on mstack
  2334.     move.l    (a2),d7    ; base of object in d7
  2335.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  2336.     clr.l    d1
  2337.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  2338.     add.l    d1,d7    ; d7 points to idx hdr
  2339.     move.l    (SP)+,d0    ; get the index
  2340.     add.l    d0,d7    ; add the index
  2341.     move.l    (SP)+,d1    ; get increment
  2342.     add.b    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  2343.     gonext
  2344. *
  2345. ; fast left lshift ( val #shift -- val )
  2346.     dcode    <<,x,inc1,shfl
  2347.     popd0
  2348.     popd1
  2349.     lsl.l    d0,d1
  2350.     move.l    d1,-(SP)
  2351.     gonext
  2352. *
  2353. ; fast right lshift ( val #shift -- val )
  2354.     dcode    >>,x,shfl,shfr
  2355.     popd0
  2356.     popd1
  2357.     lsr.l    d0,d1
  2358.     move.l    d1,-(SP)
  2359.     gonext
  2360. *
  2361.     dcode    (ABS),x,shfr,abs_    ; leave absolute of mstack addr
  2362.     move.l    d5,a2
  2363.     move.l    (a2),d0
  2364.     add.l    a3,d0
  2365.     move.l    d0,-(SP)
  2366.     gonext
  2367. *
  2368.     dcode    COUNT,x,abs_,count
  2369.     move.l    (SP),d0
  2370.     add.l    #1,(SP)
  2371.     clr.l    d1
  2372.     move.b    0(A3,d0.l),d1
  2373.     move.l    d1,-(SP)
  2374.     gonext
  2375. *
  2376.     dcode    DEPTH,x,count,depth
  2377.     move.l    SP,d0
  2378.     sub.l    a3,d0
  2379.     move.l    #(s09-origin),d7
  2380.     sub.l    0(a3,d7.l),d0
  2381.     neg.l    d0
  2382.     asr.l    #2,d0
  2383.     pushD0
  2384.     gonext
  2385. *
  2386.     dcode    FILL,x,depth,fil
  2387.     popD0
  2388. fill1    popD1
  2389.     move.l    (SP)+,d7
  2390.     lea    0(a3,d7.l),a0
  2391. fil1    subq.l    #1,d1
  2392.     bmi    fil2
  2393.     move.b    d0,(a0)+
  2394.     bra.s    fil1
  2395. fil2    gonext
  2396. *
  2397.     dcode    ERASE,x,fil,era
  2398.     clr.l    d0
  2399.     bra.s    fill1
  2400. *
  2401.     dcode    BLANKS,x,era,blanks
  2402.     moveq    #$20,d0
  2403.     bra.s    fill1
  2404. *    
  2405.     dcode    +BASE,x,blanks,basadr
  2406.     move.l    (SP)+,d7
  2407.     pea    0(a3,d7.l)    ; push absolute address = base+pa
  2408.     gonext
  2409. *
  2410.     dcode    -BASE,x,basadr,minbas
  2411.     move.l    a3,d0
  2412.     sub.l    d0,(SP)
  2413.     gonext
  2414. *
  2415.     dcode    ROT,x,minbas,rot
  2416.     popD0
  2417.     popD1
  2418.     move.l    (SP),d2
  2419.     move.l    d1,(SP)
  2420.     pushD0
  2421.     move.l    d2,-(SP)
  2422.     gonext
  2423. *
  2424.     dcode    PICK,x,rot,pick
  2425.     move.l    (SP),d0
  2426.     asl.l    #2,d0    ; index * 4
  2427.     move.L    0(SP,d0.w),(SP)
  2428.     gonext
  2429. *
  2430.     dcode    RESET,x,pick,rset    ; reboot the machine
  2431.     reset
  2432. *
  2433.     dcode    (FDOS),x,rset,fdos    ; general file system trap call
  2434.     lea    fdtrap(PC),a0    ; stack : (pblock trap --- result)
  2435.     clr.l    d1
  2436.     move.w    (SP)+,d1    ; function selector to d0 later
  2437.     move.w    (SP)+,(a0)    ; move in trap#
  2438.     movea.l    (SP)+,a0    ; file control block
  2439.     adda.l    a3,a0    ; make it absolute
  2440.     tst.b    hwpavail9+3-origin(a3)    ; flush cache if necessary
  2441.     beq.s    fdt0
  2442.     moveq    #1,d0
  2443.     _HWPriv
  2444. fdt0    move.l    d1,d0    ; restore d0
  2445. fdtrap    DC.W    0    ; call Toolbox
  2446.     move.w    ioResult(a0),d0    ; leave result on stack
  2447.     ext.l    d0
  2448.     pushd0
  2449.     gonext
  2450. *
  2451.     dcode    (MAKE),x,fdos,make_
  2452.     move.l    (SP)+,a0    ; parm block offset in a0
  2453.     add.l    a3,a0    ; make it absolute
  2454.     _Hcreate        ; call Toolbox
  2455.     move.w    ioResult(a0),d0    ; leave result on stack
  2456.     ext.l    d0
  2457.     pushd0
  2458.     gonext
  2459. *
  2460.     dcode    (OPEN),x,make_,open_
  2461.     popd0        ; get access mode in d0
  2462.     move.l    (SP)+,a0    ; parm block offset in a0
  2463.     add.l    a3,a0    ; make it absolute
  2464.     move.b    d0,ioPermssn(a0)    ; set i/o permission
  2465.     _Hopen        ; open the file
  2466.     move.w    ioResult(a0),d0    ; leave result on stack
  2467.     ext.l    d0
  2468.     pushd0
  2469.     gonext
  2470. *
  2471.     dcode    (CLOSE),x,open_,close_
  2472.     move.l    (SP)+,a0    ; parm block offset in a0
  2473.     add.l    a3,a0    ; make it absolute
  2474.     _close        ; call Toolbox CLOSE
  2475.     move.w    ioResult(a0),d0    ; leave result on stack
  2476.     ext.l    d0
  2477.     pushd0
  2478.     gonext
  2479. *
  2480.     dcode    (DELETE),x,close_,delet_
  2481.     move.l    (SP)+,a0    ; parm block offset in a0
  2482.     add.l    a3,a0    ; make it absolute
  2483.     _delete        ; call Toolbox DELETE
  2484.     move.w    ioResult(a0),d0    ; leave result on stack
  2485.     ext.l    d0
  2486.     pushd0
  2487.     gonext
  2488. *
  2489.     dcode    (READ),x,delet_,read_
  2490.     popD0        ; pop buffer address into d0
  2491.     add.l    a3,d0    ; make it absolute
  2492.     popD1        ; get count in d1
  2493.     move.l    (SP)+,a0    ; parm block offset in a0
  2494.     add.l    a3,a0    ; make it absolute
  2495.     move.l    d0,iobuffer(a0)    ; store buffer pointer in parm block
  2496.     move.l    d1,ioReqCount(a0)    ; store count in parm block
  2497.     _read        ; call Toolbox read
  2498.     move.w    ioResult(a0),d0    ; leave result on stack
  2499.     ext.l    d0
  2500.     pushd0
  2501.     gonext
  2502. *
  2503.     dcode    (WRITE),x,read_,write_
  2504.     popD0        ; pop buffer address into d0
  2505.     add.l    a3,d0    ; make it absolute
  2506.     popD1        ; get count in d1
  2507.     move.l    (SP)+,a0    ; parm block offset in a0
  2508.     add.l    a3,a0    ; make it absolute
  2509.     move.l    d0,iobuffer(a0)    ; store buffer pointer in parm block
  2510.     move.l    d1,ioReqCount(a0)    ; store count in parm block
  2511.     _write        ; call Toolbox read
  2512.     move.w    ioResult(a0),d0    ; leave result on stack
  2513.     ext.l    d0
  2514.     pushD0
  2515.     gonext
  2516. *
  2517.     dcode    (LSEEK),x,write_,lseek
  2518.     popD0        ; pickup position offset in D0
  2519.     popD1        ; pickup positioning mode in D1
  2520.     move.l    (SP)+,a0    ; pop pba
  2521.     add.l    a3,a0
  2522.     move.l    d0,ioPosOffset(a0)    ; set offset in parm block
  2523.     move.w    d1,ioPosMode(a0)    ; set mode in parm block
  2524.     _SetFPos
  2525.     move.w    ioResult(a0),d0    ; leave result on stack
  2526.     ext.l    d0
  2527.     pushd0
  2528.     gonext
  2529. *
  2530. ; ------- (;CODE) is needed by the following words
  2531.     dcol    (;CODE),x,lseek,pscode
  2532.     cfas    rfrom,latest,pfa,cfa,store,semis
  2533. *
  2534. ; ------- The following words are ;CODE type words
  2535.     dcol    CONSTANT,x,pscode,const
  2536.     cfas    kreate,comma
  2537.     scode        ; points to (;CODE)
  2538. concode    addq.l    #4,d6    ; runtime code for constant
  2539.     move.l    0(a3,d6.l),-(SP)
  2540.     gonext
  2541. *
  2542.     dcol    :,I,const,colon    ; this colon doesn't set Context
  2543.     cfas    qexec,stcsp    ; to Current.
  2544.     cfas    kreate,rbrak
  2545.     scode
  2546. colcode    suba.l    a3,a4    ; convert absolute address to offset
  2547.     move.l    a4,-(a6)    ; push current IP to Return stack
  2548.     addq.l    #4,d6    ; advance WP to pfa of word being def.
  2549.     lea    0(a3,d6.l),a4    ; get absolute addr in A4
  2550.     gonext
  2551. *
  2552.     dcol    DOES>,x,colon,does
  2553.     cfas    rfrom,latest,pfa
  2554.     DATA    store-origin
  2555.     scode
  2556. doescode    addq.l    #4,d6
  2557.     suba.l    a3,a4
  2558.     move.l    a4,-(a6)
  2559.     move.l    0(a3,d6.l),d7
  2560.     lea    0(a3,d7.l),a4
  2561.     addq.l    #4,d6
  2562.     move.l    d6,-(SP)
  2563.     gonext
  2564. *
  2565.     dcol    VARIABLE,x,does,varb
  2566.     cfas    const
  2567.     scode
  2568. varcode    addq.l    #4,d6
  2569.     move.l    d6,-(SP)
  2570.     gonext
  2571. *
  2572.     dcode    OBJMP,x,varb,objmp
  2573.     move.l    #(obcode-origin),d0    ; get addr of object code
  2574.     jmp    0(a3,d0.l)    ; obj puts its addr on stack
  2575. *
  2576.     dcol    (AB"),x,objmp,abq_    ; abort" runtime word
  2577.     cfas    mindup
  2578.     eif.    abq11
  2579.     cfas    cr,lit,10+origin,beep,here,count,type
  2580.     cfas    lit,63+origin,emit,space,R,count,type,abort
  2581.     else.    abq11
  2582.     cfas    rfrom,count,plus,aline,tor
  2583.     ethen.    abq11
  2584.     cfas    semis
  2585. *
  2586.     dcol    PREFIX,x,abq_,prefix    ; prefix builder for mcfa
  2587.     cfas    builds,times4,wcomma,immed
  2588.     cfas    does
  2589. dopref    cfas    fetpfa
  2590.     cfas    cfa,over,wfetch,plus
  2591.     cfas    swap_,min4,over,fetch,lit,6+origin,subt
  2592.     cfas    fetch,subt,abq_
  2593.     STR    "invalid prefix "
  2594.     cfas    state
  2595.     if.    pre11
  2596.     cfas    comma,semis
  2597.     then.    pre11
  2598.     cfas    exec,semis
  2599. *
  2600. ; execute 1cfa of object vector ivar
  2601.     dcode    X1CFA,x,prefix,x1cfa
  2602.     move.l    d5,a2    ; 1cfa is the fetch/deferred exec routine
  2603.     clr.l    d6
  2604.     move.w    (a4)+,d6    ; get offset to ivar
  2605.     add.l    (a2),d6    ; add base addr to get 1cfa addr in WP
  2606.     move.l    0(a3,d6.l),d7    ; get code addr in d7
  2607.     jmp    0(a3,d7.l)
  2608. *
  2609.     dcol    VOCABULARY,x,x1cfa,vocab
  2610.     cfas    builds
  2611.     mlit    $8120
  2612.     cfas    wcomma,currnt,min2,comma,here,vocl,comma
  2613.     cfas    vocl2,does
  2614. dovocab    cfas    plus2,contxt2,semis
  2615. *
  2616. ; define prefixes for 3cfa variables,vects
  2617.     ddoes    PUT,I,vocab,preput,dopref    ; 2cfa for all
  2618.     DC.W    8
  2619.     ddoes    PUTDEF,I,preput,prputd,dopref    ; 1cfa for sysVe
  2620.     DC.W    4
  2621. ; define code handlers for 3cfa variables,vects
  2622.     DATA    0    ; fetch code for sysvect
  2623.     DC.W    8    ; len to vect's pfa from 1cfa
  2624. dofetchv    addq.l    #8,d6    ; advance wp to pfa
  2625.     move.l    0(a3,d6.l),-(SP)    ; get contents of pfa
  2626.     gonext
  2627. *
  2628.     DATA    preput+4-origin    ; store code
  2629.     DC.W    4    ; len to vect's pfa from 1cfa
  2630. dostore    addq.l    #4,d6    ; advance wp to pfa
  2631.     move.l    (SP)+,0(a3,d6.l)    ; get contents of pfa
  2632.     gonext
  2633. *
  2634.     DATA    0    ; increment code
  2635.     DC.W    8    ; len to vect's pfa from 1cfa
  2636. doincr    addq.l    #8,d6    ; advance wp to pfa
  2637.     popd0
  2638.     add.l    d0,0(a3,d6.l)    ; increment contents of pfa
  2639.     gonext
  2640. *
  2641.     DC.W    12
  2642. doexec    add.l    #12,d6
  2643.     move.l    0(a3,d6.l),d6    ; get address to execute
  2644.     move.l    0(a3,d6.l),d7    ; get contents of CFA
  2645.     jmp    0(a3,d7.l)    ; execute the code
  2646.     DC.W    12    ; execute a system vector table entry
  2647. dosexec    add.l    #12,d6
  2648.     move.l    userdp(PC),d0    ; rel base of system vector table
  2649.     add.l    0(a3,d6.l),d0    ; add offset into table
  2650.     move.l    0(a3,d0.l),d1    ; get vector contents
  2651.     beq    dodeflt    ; if 0, exec default
  2652.     move.l    d1,d6
  2653.     bra.s    sexec
  2654. dodeflt    move.l    4(a3,d6.l),d6    ; get default cfa to execute
  2655. sexec    move.l    0(a3,d6.l),d7    ; get contents of CFA
  2656.     jmp    0(a3,d7.l)    ; execute the code
  2657. *
  2658.     DATA    prputd+4-origin
  2659.     DC.W    8    ; set offset, default for system vector
  2660. doputdef    addq.l    #8,d6
  2661.     move.l    (SP)+,0(a3,d6.l)    ; set the offset
  2662.     move.l    (SP)+,4(a3,d6.l)    ; set the default
  2663.     gonext
  2664. *
  2665.     DATA    preput+4-origin
  2666.     DC.W    4    ; set sys vector table entry for this vect
  2667. doputsv    addq.l    #4,d6
  2668.     move.l    userdp(PC),d0
  2669.     add.l    0(a3,d6.l),d0    ; add the offset
  2670.     move.l    (SP)+,0(a3,d0.l)    ; store the vector
  2671.     gonext
  2672. *
  2673.     DC.W    12    ; len to value's pfa from 1cfa
  2674. dofetch    add.l    #12,d6    ; advance wp to pfa
  2675.     move.l    0(a3,d6.l),-(SP)    ; get contents of pfa
  2676.     gonext
  2677. *
  2678.     dcol    ",",x,prputd,comma    ; begin comman dict entry
  2679.     cfas    here,store,pfour,allot,semis
  2680. *
  2681.     dcol    "W,",x,comma,wcomma    ; begin Wcomma dict entry
  2682.     cfas    here,wstore,lit,2+origin,allot,semis
  2683. *
  2684.     dcol    "C,",x,wcomma,ccomma    ; begin C, dict entry
  2685.     cfas    here,cstore,pone,allot,semis
  2686. *
  2687.     dcol    @PFA,x,ccomma,fetpfa
  2688.     cfas    mfind,zequ,abq_
  2689.     STR    "not found  "
  2690.     cfas    drop,semis
  2691. *
  2692.     dcol    LFA,x,fetpfa,lfa
  2693.     mlit    8
  2694.     cfas    subt,semis
  2695. *
  2696.     dcol    NFA,x,lfa,nfa
  2697.     mlit    9
  2698.     cfas    subt
  2699.     mlit    -1
  2700.     cfas    traver,semis
  2701. *
  2702.     dcol    PFA,x,nfa,pfa
  2703.     mlit    1
  2704.     cfas    traver,lit,9+origin,plus,semis
  2705. *
  2706.     dcol    >LINE,x,pfa,toline
  2707.     cfas    docs
  2708.     if.    L100
  2709.     cfas    min2
  2710.     then.    L100
  2711.     cfas    semis
  2712. *
  2713.     dcol    LINE>,x,toline,linefm
  2714.     cfas    docs
  2715.     if.    L101
  2716.     cfas    plus2
  2717.     then.    L101
  2718.     cfas    semis
  2719. *
  2720.     dcol    ALIGN,x,linefm,aline
  2721.     cfas    dup
  2722.     mlit    1
  2723.     cfas    and_,plus,semis
  2724. *
  2725.     dcol    DECIMAL,x,aline,decim
  2726.     mlit    $0a
  2727.     cfas    base2,semis
  2728. *
  2729.     dcol    HEX,x,decim,hex
  2730.     mlit    $10
  2731.     cfas    base2,semis
  2732. *
  2733.     dcol    (."),x,hex,dotq_
  2734.     cfas    r,count,dup,plus1,aline,rfrom,plus,toR,type
  2735.     cfas    semis
  2736. *
  2737.     dcol    PAD,x,dotq_,pad
  2738.     mlit    padbuf-origin
  2739.     cfas    semis
  2740. *
  2741.     dcol    #>,x,pad,enum
  2742.     cfas    drop2,hld,pad,over,subt,semis
  2743. *
  2744.     dcol    HOLD,x,enum,hold
  2745.     DATA    pmone-origin
  2746.     cfas    hld1,hld,cstore,semis
  2747. *
  2748.     dcol    SIGN,x,hold,sign
  2749.     cfas    rot,zless
  2750.     if.    Z3
  2751.     mlit    $2d
  2752.     cfas    hold
  2753.     then.    Z3
  2754.     cfas    semis
  2755. *
  2756.     dcol    #,x,sign,sharp
  2757.     cfas    base,msmod,rot
  2758.     mlit    9
  2759.     cfas    over,less
  2760.     if.    Z4
  2761.     mlit    7
  2762.     cfas    plus
  2763.     then.    Z4
  2764.     mlit    $30
  2765.     cfas    plus,hold,semis
  2766. *
  2767.     dcol    #S,x,sharp,sharps
  2768.     begin.    Z5
  2769.     cfas    sharp,dup2,or_,zequ
  2770.     until.    Z5
  2771.     cfas    semis
  2772. *
  2773.     dcol    <#,x,sharps,snum
  2774.     cfas    pad,hld2,semis
  2775. *
  2776.     dcol    D.R,x,snum,ddotr
  2777.     cfas    toR,swap_,over,dabs,snum,sharps,sign,enum,rfrom
  2778.     cfas    over,subt,spaces,type,semis
  2779. *
  2780.     dcol    D.,x,ddotr,ddot
  2781.     mlit    0
  2782.     cfas    ddotr,space,semis
  2783. *
  2784.     dcol    .,x,ddot,dot
  2785.     cfas    sToD,ddot,semis
  2786. *
  2787.     dcol    U.,x,dot,udot
  2788.     mlit    0
  2789.     cfas    ddot,semis
  2790. *
  2791.     dcol    .R,x,udot,dotR
  2792.     cfas    toR,sToD,rfrom,ddotr,semis
  2793. *
  2794.     dcol    ?,x,dotR,quest
  2795.     cfas    fetch,dot,semis
  2796. *
  2797.     dcol    SPACE,x,quest,space
  2798.     cfas    bl,emit,semis
  2799. *
  2800.     dcol    SPACES,x,space,spaces
  2801.     mlit    0
  2802.     do.    Z7
  2803.     cfas    bl,emit
  2804.     loop.    Z7
  2805.     cfas    semis
  2806. *
  2807.     dcol    -TRAILING,x,spaces,mtrail
  2808.     cfas    dup
  2809.     mlit    0
  2810.     do.    Z8
  2811.     cfas    over,over,plus,min1,cfetch,bl,subt
  2812.     eif.    Z10
  2813.     cfas    leave
  2814.     else.    Z10
  2815.     cfas    min1
  2816.     ethen.    Z10
  2817.     loop.    Z8
  2818.     cfas    semis
  2819. *
  2820.     dcol    N>COUNT,x,mtrail,ncount
  2821.     cfas    count
  2822.     mlit    $1f
  2823.     cfas    and_,semis
  2824. *
  2825.     dcol    ID.,x,ncount,iddot
  2826.     cfas    ncount,type,space,semis
  2827. *
  2828.     dcol    EMIT,x,iddot,emit
  2829.     cfas    dup,emitvec,pemitv,pone     ; send the char via Quickdraw
  2830.     cfas    out1,semis
  2831. *
  2832.     dcol    TYPE,x,emit,type
  2833.     cfas    dup,out1,dup2,typevec,ptypev,semis
  2834.     dcol    CR,x,type,cr
  2835.     cfas    crvec,pcrvec,semis
  2836. *
  2837.     dcol    CONTBOT,x,cr,contbot
  2838.     cfas    port_,lit,windowsize+origin,plus,plus4
  2839.     cfas    wfetch,semis
  2840. *
  2841.     dcol    CONTTOP,x,contbot,conttop
  2842.     cfas    port_,lit,windowsize+origin,plus
  2843.     cfas    wfetch,semis
  2844. *
  2845.     dcol    ?LEAD,x,conttop,qlead    ; return proper leading for fo
  2846.     cfas    port_,lit,txsize+origin,plus,wfetch
  2847.     cfas    lit,120+origin,star,lit,50+origin,plus    ; Increase 120 f
  2848.     cfas    lit,100+origin,slash,semis
  2849. *
  2850.     dcol    ?LINES,x,qlead,qlines    ; number of even lines in port
  2851.     cfas    qlead,contbot,conttop    ; bottom-top of content rgn
  2852.     cfas    subt,lit,5+origin,subt,    ; less first line location
  2853.     cfas    over,plus1,subt    ; minus ?LEAD+1
  2854.     cfas    swap_,slash,semis    ; divided by ?LEAD
  2855. *
  2856.     dcol    BOTTOM,x,qlines,scrbot    ; coordinate of screen bottom
  2857.     cfas    conttop,plus4,qlead,qlines,star,plus
  2858.     cfas    semis
  2859. *
  2860.     dcol    (CR),x,scrbot,cr_    ; simulate a CR in Quickdraw
  2861.     cfas    dotcur,fetxy,swap_,drop,lit,8+origin,swap_
  2862.     cfas    dup,scrbot,grt
  2863.     eif.    x27
  2864.     cfas    pzer,qlead,minus,scroll,gotoxy
  2865.     else.    x27
  2866.     cfas    qlead,plus
  2867.     cfas    gotoxy
  2868.     ethen.    x27
  2869.     cfas    dotcur,semis
  2870. *
  2871.     dcol    (BS),x,cr_,bs_
  2872.     cfas    dotcur,fetxy,swap_,lit,6+origin,subt,lit,8+origin,max
  2873.     cfas    swap_,dup2,gotoxy,curs_,pzer,curs_2
  2874.     cfas    bl,emit,curs_2,gotoxy,dotcur,semis
  2875. *
  2876.     dcol    ?TERMINAL,x,bs_,qterm
  2877.     cfas    lit,$28+origin,qevt,semis
  2878. *
  2879.     dcol    (KEY),x,qterm,key_
  2880.     mlit    $2A        ; kbd and mouse events
  2881.     cfas    getevt,lit,2+origin,grt
  2882.     eif.    Z100
  2883.     cfas    ftemsg,lit,$00ff+origin,and_
  2884.     else.    Z100
  2885.     cfas    pmone
  2886.     ethen.    Z100
  2887.     cfas    semis
  2888. *
  2889.     dcol    (DKEY),x,key_,dkey_
  2890.     cfas    ufcb,pone,lit,ftwork    ; read 1 char from disk
  2891.     cfas    read_,dup,dkerr2
  2892.     eif.    y10
  2893.     cfas    keystor,pone,curs_2    ; restore to terminal if err
  2894.     cfas    lit,13+origin
  2895.     else.    y10
  2896.     cfas    lit,ftwork,cfetch    ; leav char on stack
  2897.     ethen.    y10
  2898.     cfas    qpause,semis
  2899. *
  2900.     dcol    KEY!,x,dkey_,keystor    ; reset KEY to keyboard
  2901.     cfas    lit,key_,keyvec2,semis
  2902. *
  2903.     dcol    KEY,x,keystor,key
  2904.     cfas    keyvec,semis    ; vectored key
  2905. *
  2906.     dcol    <",x,key,diskin    ; set to disk key inpu
  2907.     cfas    ufcb,close_,dot    ; close the oldfile
  2908.     cfas    lit,useFcb,lit,80+origin,era,pzer,curs_2
  2909.     cfas    lit,34+origin,word,here,dup,cfetch,plus1
  2910.     cfas    lit,useFname,swap_,cmove
  2911.     cfas    lit,useFname,basadr,lit,useFcb,sflptr
  2912.     cfas    ufcb,pone,open_,dot
  2913.     cfas    cr,lit,dkey_,keyvec2,semis
  2914. *
  2915. ; ------------ Disk words for FORTH screen handling
  2916.     dcol    !FPTR,x,diskin,sflptr    ; ( ^fname pblock -- )
  2917.     cfas    lit,18+origin,plus,store,semis
  2918. *
  2919.     dcol    ?COMP,x,sflptr,qcomp
  2920.     cfas    state,zequ,abq_
  2921.     STR    "compilation only "
  2922.     cfas    semis
  2923. *
  2924.     dcol    ?DP,x,qcomp,qdp    ; dp grown into heap?
  2925.     cfas    room,pone,less,abq_
  2926.     STR    " out of room "
  2927.     cfas    semis
  2928. *
  2929.     dcol    ?STACK,x,qdp,qstack
  2930.     cfas    spfet,s0,swap_,uless
  2931.     cfas    abq_
  2932.     STR    "empty stack  "
  2933.     cfas    semis
  2934. *
  2935.     dcol    ?EXEC,x,qstack,qexec
  2936.     cfas    state,cstate,or_,abq_    ; err if class or forth compile
  2937.     STR    "run state only "
  2938.     cfas    semis
  2939. *
  2940.     dcol    ?PAIRS,x,qexec,qpairs
  2941.     cfas    subt,abq_
  2942.     STR    "unpaired conditionals  "
  2943.     cfas    semis
  2944. *
  2945.     dcol    ?CSP,x,qpairs,qcsp
  2946.     cfas    spfet,csp,subt,abq_
  2947.     STR    "definition not finished  "
  2948.     cfas    semis
  2949. *
  2950.     dcol    (NUMBER),x,qcsp,num_
  2951.     begin.    Z27
  2952.     cfas    plus1,dup,tor,cfetch,base,digit
  2953.     while.    Z27
  2954.     cfas    swap_,base,ustar,drop,rot,base
  2955.     cfas    ustar,dplus,dpl,plus1
  2956.     if.    Z28
  2957.     cfas    pone,dpl1
  2958.     then.    Z28
  2959.     cfas    rfrom
  2960.     repeat.    Z27
  2961.     cfas    rfrom,semis
  2962. *
  2963.     dcol    ?NUM,x,num_,qnum    ; ( addr -- d t OR f )
  2964.     cfas    pzer,pzer,rot,dup,plus1,cfetch
  2965.     mlit    $2d
  2966.     cfas    equals,dup,tor,plus,pmone
  2967.     begin.    Z30
  2968.     cfas    dpl2,num_,dup,cfetch,bl,subt
  2969.     while.    Z30
  2970.     cfas    dup,cfetch,lit,$2e+origin,subt
  2971.     if.    zz177
  2972.     cfas    rfrom,drop2,drop2,pzer,semis
  2973.     then.    zz177
  2974.     cfas    pzer
  2975.     repeat.    Z30
  2976.     cfas    drop,rfrom
  2977.     if.    Z31
  2978.     cfas    dminus
  2979.     then.    Z31
  2980.     cfas    pone,semis
  2981. *
  2982.     dcol    NUMBER,x,qnum,number    ; ( addr -- d )
  2983.     cfas    qnum,zequ,abq_
  2984.     STR    "not found  "
  2985.     cfas    semis
  2986. *
  2987.     dcol    LITERAL,I,number,liter
  2988.     cfas    state
  2989.     if.    Z32
  2990.     cfas    dup,lit
  2991.     DATA    $10000
  2992.     cfas    less,over,zless,zequ,and_
  2993.     eif.    zz39
  2994.     cfas    comp,wlit,wcomma
  2995.     else.    zz39
  2996.     cfas    comp,lit,comma    ; builds word lit if n>=0 and n<$10000
  2997.     ethen.    zz39
  2998.     then.    Z32
  2999.     cfas    semis
  3000. *
  3001.     dcol    EXPECT,x,liter,expect
  3002.     cfas    over,plus,over
  3003.     do.    Z33
  3004.     cfas    key,dup,lit,8+origin,equals    ; bs ?
  3005.     eif.    Z34
  3006.     cfas    drop,dup,i,equals,dup,rfrom,min2,plus,tor
  3007.     eif.    Z35
  3008.     cfas    lit,10+origin,beep
  3009.     else.    Z35
  3010.     cfas    bs_
  3011.     ethen.    Z35
  3012.     cfas    pzer
  3013.     else.    Z34
  3014.     cfas    dup,zequ
  3015.     if.    y118
  3016.     cfas    drop,lit,32+origin    ; map null to space
  3017.     then.    y118
  3018.     cfas    dup,lit,$0d+origin,equals
  3019.     eif.    Z36
  3020.     cfas    leave,drop,pzer,pzer,cr
  3021.     else.    Z36
  3022.     cfas    dup
  3023.     ethen.    Z36
  3024.     cfas    r,cstore,pzer,r,plus1,cstore
  3025.     ethen.    Z34
  3026.     cfas    echovec
  3027.     loop.    Z33
  3028.     cfas    drop,semis
  3029. *
  3030.     dcol    WORD,x,expect,word
  3031.     cfas    tib
  3032.     cfas    in,plus,swap_,enclos
  3033.     cfas    word_,semis
  3034. *
  3035.     dcol    WORD",x,word,wordq    ; lower-case version of word
  3036.     cfas    tib,in,plus,lit,34+origin,enclos
  3037.     cfas    lcword,here,semis
  3038. *
  3039.     dcol    FIND,x,wordq,mfind
  3040.     cfas    bl,word,ufind,dup,zequ
  3041.     if.    w72
  3042.     cfas    drop,here,contxt,fetch
  3043.     cfas    find_,dup,zequ
  3044.     if.    Z38
  3045.     cfas    contxt,currnt,subt
  3046.     if.    Z40
  3047.     cfas    drop,here,latest,find_
  3048.     then.    Z40
  3049.     then.    Z38
  3050.     then.    w72
  3051.     cfas    semis
  3052. *
  3053.     ADJST        ; X - null word
  3054. lkx    DC.B    $C1
  3055.     DC.B    $00
  3056.     DATA    lkmfind-origin
  3057.     DATA    colcode-origin    ; not Fig standard -
  3058.     cfas    rfrom,drop    ; note: doesn't support Forth screens
  3059.     cfas    semis
  3060. *
  3061.     dcol    "S,",x,x,scomma    ; begin S, dict entry
  3062.     cfas    here,dup,cfetch,plus1,dup
  3063.     cfas    allot,pone,and_
  3064.     if.    sc10
  3065.     cfas    pzer,ccomma
  3066.     then.    sc10
  3067.     cfas    dup,rot,toggle,semis
  3068. *
  3069.     dcol    (CREATE),x,scomma,creat_
  3070.     cfas    here,pone,and_
  3071.     if.    Z430
  3072.     cfas    pzer,ccomma
  3073.     then.    Z430
  3074.     cfas    docs
  3075.     if.    Z410
  3076.     cfas    line_,wcomma
  3077.     then.    Z410
  3078.     cfas    mfind
  3079.     if.    Z420
  3080.     cfas    verbose
  3081.     eif. Z425
  3082.     cfas    drop,nfa,iddot,dotq_
  3083.     STR    "is redefined "
  3084.     cfas    cr
  3085.     else. Z425
  3086.     cfas    drop2
  3087.     ethen. Z425
  3088.     then. Z420
  3089.     cfas    lit,$80+origin,scomma
  3090.     cfas    latest,comma,currnt
  3091.     cfas    store,here,plus4,comma,semis
  3092. *
  3093.     dcol    (INTRP),x,creat_,intrp_
  3094.     begin.    Z43
  3095.     cfas    mfind
  3096.     eif.    Z44
  3097.     cfas    state,less
  3098.     eif.    Z45
  3099.     cfas    cfa,comma
  3100.     else.    Z45
  3101.     cfas    cfa,exec
  3102.     ethen.    Z45
  3103.     else.    Z44
  3104.     cfas    here,number,dpl,plus1
  3105.     eif.    Z46
  3106.     cfas    dliter
  3107.     else.    Z46
  3108.     cfas    drop,liter
  3109.     ethen.    Z46
  3110.     ethen.    Z44
  3111.     cfas    qdp,qstack
  3112.     again.    Z43
  3113.     cfas    semis
  3114. *
  3115.     dcol    !CSP,x,intrp_,stcsp
  3116.     cfas    spfet,csp2,semis
  3117. *
  3118.     dcol    QUERY,x,stcsp,query
  3119.     cfas    tib,lit,$99+origin
  3120.     cfas    expvec,pzer,in2,semis
  3121. *
  3122.     dcol    <[,I,query,lbrak
  3123.     mlit    0
  3124.     cfas    state2,semis
  3125. *
  3126.     dcol    ]>,x,lbrak,rbrak
  3127.     mlit    $c0
  3128.     cfas    state2,semis
  3129. *
  3130.     dcol    DEFINITIONS,x,rbrak,defs
  3131.     cfas    contxt,currnt2,semis
  3132. *
  3133.     dcol    <BUILDS,x,defs,builds
  3134.     mlit    0
  3135.     cfas    const,semis
  3136. *
  3137.     dcol    OK,x,builds,ok
  3138.     cfas    depth,ptwo,dotr,base,dup
  3139.     cfas    lit,10+origin,equals
  3140.     eif.    xx11
  3141.     cfas    lit,45+origin,emit
  3142.     else.    xx11
  3143.     cfas    dup,lit,16+origin,equals
  3144.     eif.    xx12
  3145.     cfas    lit,36+origin,emit
  3146.     else.    xx12
  3147.     cfas    lit,63+origin,emit
  3148.     ethen.    xx12
  3149.     ethen.    xx11
  3150.     cfas    drop,lit,62+origin,emit
  3151.     cfas    semis
  3152. *
  3153.     dcode    Q,x,ok,q_
  3154.     clr.w    -(sp)
  3155.     _hilitemenu
  3156.     gonext
  3157. *
  3158.     dcol    QUIT,x,ok,quit
  3159.     cfas    pzer,in2
  3160.     cfas    lbrak,quvec,q_
  3161.     cfas    cr,ok
  3162.     begin.    Z48
  3163.     cfas    qdp,rpstor,query,interp,state,zequ
  3164.     if.    Z50
  3165.     cfas    ok
  3166.     then.    Z50
  3167.     again.    Z48
  3168.     cfas    semis
  3169. *
  3170.     dcol    BACK,x,quit,back
  3171.     cfas    here,subt,comma,semis
  3172. *
  3173.     dcol    FWD,x,back,fwd    ; fill in fwd branch
  3174.     cfas    here,over,subt,swap_,store,semis
  3175. *
  3176.     dcol    BEGIN,I,fwd,begin
  3177.     cfas    qcomp,here,pone,semis
  3178. *
  3179.     dcol    THEN,I,begin,then
  3180.     cfas    qcomp,lit,2+origin,qpairs,fwd,semis
  3181. *
  3182.     dcol    DO,I,then,do    ; compiles fwd branch for smart exit
  3183.     cfas    comp,do_,here,pzer,comma,lit,3+origin,semis
  3184. *
  3185.     dcol    LOOP,I,do,loop
  3186.     cfas    lit,3+origin,qpairs,comp,loop_,dup,plus4,back
  3187.     cfas    fwd,semis
  3188. *
  3189.     dcol    +LOOP,I,loop,ploop
  3190.     cfas    lit,3+origin,qpairs,comp,ploop_,dup,plus4,back
  3191.     cfas    fwd,semis
  3192. *
  3193.     dcol    COMPILE,x,ploop,comp
  3194.     cfas    qcomp,rfrom,dup,plus4
  3195.     cfas    tor,fetch,comma,semis
  3196.     dcol    [COMPILE],I,comp,bcomp
  3197.     cfas    fetpfa,cfa,comma,semis
  3198. *
  3199.     dcol    DLITERAL,I,bcomp,dliter
  3200.     cfas    state
  3201.     if.    Z51
  3202.     cfas    swap_,liter,liter
  3203.     then.    Z51
  3204.     cfas    semis
  3205. *
  3206.     dcol    UNTIL,I,dliter,until
  3207.     cfas    pone,qpairs,comp,bran0,back,semis
  3208. *
  3209.     dcol    AGAIN,I,until,again
  3210.     cfas    pone,qpairs,comp,bran,back,semis
  3211. *
  3212.     dcol    REPEAT,I,again,repeat
  3213.     cfas    tor,tor,again,rfrom,rfrom,min2
  3214.     cfas    then,semis
  3215. *
  3216.     dcol    IF,I,repeat,xif
  3217.     cfas    comp,bran0,here,pzer,comma,lit,2+origin,semis
  3218. *
  3219.     dcol    ELSE,I,xif,xelse
  3220.     cfas    lit,2+origin,qpairs,comp,bran,here,pzer,comma
  3221.     cfas    swap_,lit,2+origin,then,lit,2+origin,semis
  3222. *
  3223.     dcol    WHILE,I,xelse,while
  3224.     cfas    xif,plus2,semis
  3225. *
  3226.     dcol    EXIT,I,while,exit
  3227.     cfas    latest,pfa,cfa,fetch    ; is this a pcolon def?
  3228.     cfas    lit,pcolcode,equals
  3229.     eif.    se10
  3230.     cfas    comp,semip    ; yes, put in parm denester
  3231.     else.    se10
  3232.     cfas    comp,semis
  3233.     ethen.    se10
  3234.     cfas    semis
  3235. *
  3236.     dcol    ;,I,exit,semi    ; immediate - semicolon def
  3237.     cfas    qcsp,exit,lbrak,semis
  3238. *
  3239.     dcol    .",I,semi,dotq
  3240.     cfas    state
  3241.     eif.    Z52
  3242.     cfas    comp,dotq_
  3243.     cfas    wordq    ; lower-case word
  3244.     cfas    cfetch,plus1,aline,allot
  3245.     else.    Z52
  3246.     cfas    wordq,count,type
  3247.     ethen.    Z52
  3248.     cfas    semis
  3249. *
  3250.     dcol    IMMEDIATE,x,dotq,immed
  3251.     cfas    latest,lit,$40+origin,toggle,semis
  3252. *
  3253.     dcol    LATEST,x,immed,latest
  3254.     cfas    currnt,fetch,semis
  3255. *
  3256.     dcol    (,I,latest,lparen
  3257.     cfas    lit,$29+origin,word,semis
  3258. *
  3259.     ADJST    
  3260. lktick    DC.B    $c1    ; tick
  3261.     DC.B    $27
  3262.     DATA    lklparen-origin
  3263. tick    DATA    colcode-origin
  3264.     cfas    fetpfa,liter,semis
  3265. *
  3266.     dcol    FORGET,x,tick,forget
  3267.     cfas    defs    ; set current to context
  3268.     cfas    tick,dup,fence,uless,abq_
  3269.     STR    "in protected dictionary  "
  3270.     cfas    dup,nfa,dp2,lfa,fetch,currnt    ; leave line# if sources on
  3271.     cfas    store,semis    ; otherwise might forget nec stuff
  3272. *
  3273.     dcol    ROOM,x,forget,room    ; leave dict space left
  3274.     cfas    msiz,fetch,dp,bdp,fetch
  3275.     cfas    subt,subt,semis
  3276. *
  3277.     dcol    GREET,x,room,greet
  3278.     cfas    cls
  3279.     mlit    hello-origin
  3280.     cfas    count,type,cr
  3281.     mlit    bytesleft-origin
  3282.     cfas    count,type
  3283.     cfas    room,dot,cr
  3284.          cfas    lerror,fetch,pone,equals
  3285.     if.        Z53
  3286.     cfas    cr
  3287.     mlit    advise-origin
  3288.     cfas    count,type
  3289.     then.    Z53
  3290.     cfas    semis
  3291. *
  3292.     dcol    COLD,x,greet,xcold
  3293.     cfas    lit,aregn,fetch,zequ
  3294.     if.    w59
  3295.     cfas    intool    ; only if we haven't gotten heap already
  3296.     then.    w59
  3297.     cfas    lit,inits0,fetch,s02,lit,initr0,fetch,r02
  3298.     cfas    lit,initfenc,fetch,fence2,lit,initvocl,fetch,vocl2
  3299.     cfas    lit,initdp,fetch,dp2,lit,initmp,fetch,m02
  3300.     cfas    lit,initlast,fetch,lit,forth_
  3301.     cfas    lit,$0a+origin,plus,store,decim,spstor,mpstor    \ careful on the 0a
  3302.     cfas    forth_,defs,objini,greet,quit,semis
  3303. *
  3304.     dcol    .PAUSE,x,xcold,dpause
  3305.     cfas    lit,pausemsg,count,type,semis
  3306. *
  3307.     dcol    ?PAUSE,x,dpause,qpause    ; check if user wants to stop
  3308.     cfas    qterm
  3309.     if.    w43
  3310.     cfas    key_,drop,cr,dpause
  3311.     cfas    key_,cr,lit,0+origin,out2,lit,32+origin,grt
  3312.     if.    w44
  3313.     cfas    abort
  3314.     then.    w44
  3315.     then.    w43
  3316.     cfas    semis
  3317. *
  3318.     dcol    ABORT,x,qpause,abort
  3319.     cfas    cr
  3320.     cfas    spstor,mpstor,lit,key_,keyvec2,decim
  3321.     cfas    pone,curs_2,qstack,lbrak,forth_
  3322.     cfas    defs,abvec
  3323.     cfas    lit,$a850+origin,trap_    ; initCursor
  3324.     cfas    quit,semis
  3325. *
  3326.     ddoes    YERK,x,abort,forth_,dovocab    ; FORTH vocabulary
  3327.     DC.W    $8120
  3328. vlf    DATA    lastdef-origin
  3329.     DATA    0
  3330. *
  3331.     dcol    .VAL,x,forth_,dotval
  3332.     cfas    dotr,lit,2+origin,spaces,semis
  3333. *
  3334.     dcol    ?CFA,x,dotval,qcfa
  3335.     cfas    dup,plus4,nfa,ncount
  3336.     cfas    tor,r,plus,plus4,aline
  3337.     cfas    over,equals,rfrom,land_,semis
  3338. *
  3339.     dcol    (.STACK),x,qcfa,dstak_
  3340.     cfas    base,lit,ftwork1,store,dup2,grt    ; preserve current base
  3341.     eif.    z61
  3342.     do.    z62
  3343.          cfas    qpause
  3344.     cfas    cr,ifetch,dup,decim
  3345.     cfas    lit,8+origin,dotval,dup,hex,lit,36+origin,emit
  3346.     cfas    pzer,lit,6+origin,ddotr
  3347.     cfas    lit,3+origin,spaces,aline,min4,plus1,false
  3348.     eif.    z63
  3349.     cfas    plus4,nfa,iddot
  3350.     else.    z63
  3351.     cfas    drop
  3352.     ethen.    z63
  3353.     cfas    pfour
  3354.     ploop.    z62
  3355.     else.    z61
  3356.     cfas    lit,emptymsg,count,type,less
  3357.     cfas    abq_
  3358.     STR    "Stack Underflow  "
  3359.     ethen.    z61
  3360.     cfas    lit,ftwork1,fetch,base2,cr    restore base
  3361.     cfas    semis
  3362. *
  3363. Lastdef    dcol    .S,x,dstak_,dots
  3364.     cfas    spfet,s0,swap_,lit,dsmsg
  3365.     cfas    count,type,dstak_,r0,rpfet,lit,rsmsg
  3366.     cfas    count,type,dstak_,m0,mpfet,lit,msmsg
  3367.     cfas    count,type,dstak_
  3368.     cfas    semis
  3369. *
  3370. nextdef    EQU    *
  3371.     ENDR
  3372. *
  3373.     SEG    0,32,VAR.LEN,$20
  3374. SEG0
  3375. SEG_1    JP    start,1
  3376.     JP    getInstL,1
  3377. END_1
  3378. SEG_2    JP    origin,2
  3379.     JP    coldvec,2
  3380.     JP    getDict,2
  3381. END_2
  3382. END0
  3383.     ENDR
  3384. *
  3385. *    END
  3386.     RSRC    YERK,0,32
  3387.          STR     "Yerk Version 3.6.8"
  3388.          ENDR
  3389. *
  3390.          RSRC    FREF,128,32
  3391.          ASC     'APPL'
  3392.          DATA    /0
  3393.          STR     ""
  3394.          ENDR
  3395. *
  3396.          RSRC    FREF,129,32
  3397.     ASC    'COM '
  3398.     DATA    /1
  3399.     STR    ""
  3400.     ENDR
  3401. *
  3402.     RSRC    FREF,130,32
  3403.     ASC 'USER'
  3404.     DATA /2
  3405.     STR    ""
  3406.     ENDR
  3407. *
  3408.     RSRC    FREF,131,32
  3409.     ASC    'BIN '
  3410.     DATA /3
  3411.     STR    ""
  3412.     ENDR
  3413. *
  3414.     RSRC    FREF,132,32
  3415.     ASC    'TEXT'
  3416.     DATA /4
  3417.     STR    ""
  3418.     ENDR
  3419. *
  3420.     RSRC    ICN#,128,32
  3421.     HEX    71c0.0000.cb20.0000
  3422.     HEX    c620.0000.6040.0000
  3423.     HEX    3080.0000.1900.1f80
  3424.     HEX    1900.2040.197e.4020
  3425.     HEX    1981.9810.1e8e.e408
  3426.     HEX    0ccf.3f87.3069.1803
  3427.     HEX    c864.8003.c864.4003
  3428.     HEX    c8c8.f003.c99f.8ff3
  3429.     HEX    c981.990f.c9ff.9903
  3430.     HEX    c8fd.8200.c801.8400
  3431.     HEX    c801.8200.c801.91ce
  3432.     HEX    c801.9939.c801.9f32
  3433.     HEX    c801.d724.c800.e308
  3434.     HEX    c800.0304.cfff.e322
  3435.     HEX    c000.1331.c000.1339
  3436.     HEX    ffff.e3ef.7fff.c1c6
  3437. *
  3438.     HEX    71c0.0000.fbe0.0000
  3439.     HEX    ffe0.0000.7fc0.0000
  3440.     HEX    3f80.0000.1f00.1f80
  3441.     HEX    1f00.3fc0.1f7e.7fe0
  3442.     HEX    1fff.fff0.1ffe.e7f8
  3443.     HEX    0fff.ffff.3ff9.ffff
  3444.     HEX    fffc.ffff.fffc.7fff
  3445.     HEX    fff8.ffff.ffff.ffff
  3446.     HEX    ffff.ff0f.ffff.ff03
  3447.     HEX    ffff.fe00.ffff.fc00
  3448.     HEX    ffff.fe00.ffff.ffce
  3449.     HEX    ffff.ffff.ffff.fffe
  3450.     HEX    ffff.fffc.ffff.fff8
  3451.     HEX    ffff.fffc.ffff.fffe
  3452.     HEX    ffff.ffff.ffff.c1ff
  3453.     HEX    ffff.c1ef.7fff.c1c6
  3454.     ENDR
  3455. *
  3456.     RSRC    ICN#,129,32
  3457.     HEX    71c7.fffe.cb2c.0001
  3458.     HEX    c62c.0001.604f.fff9
  3459.     HEX    3087.fff9.1900.0019
  3460.     HEX    1900.0019.197e.0019
  3461.     HEX    1981.0019.1e8e.0019
  3462.     HEX    0ccc.0019.3068.0019
  3463.     HEX    c864.0019.c864.0019
  3464.     HEX    c8c8.fc19.c99f.8219
  3465.     HEX    c981.9919.c9ff.9919
  3466.     HEX    c8fd.821f.c801.840e
  3467.     HEX    c801.8200.c801.91ce
  3468.     HEX    c801.9939.c801.9f32
  3469.     HEX    c801.d724.c800.e308
  3470.     HEX    c800.0304.cfff.e322
  3471.     HEX    c000.1331.c000.1339
  3472.     HEX    ffff.e3ef.7fff.c1c6
  3473. *
  3474.     HEX    71c7.fffe.fbef.ffff
  3475.     HEX    ffef.ffff.7fcf.ffff
  3476.     HEX    3fff.ffff.1fff.ffff
  3477.     HEX    1fff.ffff.1fff.ffff
  3478.     HEX    1fff.ffff.1fff.ffff
  3479.     HEX    0fff.ffff.3fff.ffff
  3480.     HEX    ffff.ffff.ffff.ffff
  3481.     HEX    ffff.ffff.ffff.ffff
  3482.     HEX    ffff.ffff.ffff.ffff
  3483.     HEX    ffff.ffff.ffff.ffff
  3484.     HEX    ffff.fff8.ffff.ffff
  3485.     HEX    ffff.ffff.ffff.ffff
  3486.     HEX    ffff.fffe.ffff.fffc
  3487.     HEX    ffff.fffc.ffff.fffe
  3488.     HEX    ffff.f3ff.ffff.f3ff
  3489.     HEX    ffff.e3ef.7fff.c1c6
  3490.     ENDR
  3491. *
  3492.     RSRC    ICN#,130,32
  3493.     HEX    71c7.fffe.cb2c.0001
  3494.     HEX    c62c.0001.604f.fff9
  3495.     HEX    3087.fff9.1900.0019
  3496.     HEX    1900.0019.1900.0019
  3497.     HEX    1900.0019.1e00.0019
  3498.     HEX    0c00.0019.3000.0019
  3499.     HEX    c800.0019.c800.0019
  3500.     HEX    c800.0019.c800.0019
  3501.     HEX    c800.0019.c800.0019
  3502.     HEX    c800.001f.c800.000f
  3503.     HEX    c800.0000.c800.01ce
  3504.     HEX    c800.0339.c800.0332
  3505.     HEX    c800.0324.c800.0308
  3506.     HEX    c800.0304.cfff.e322
  3507.     HEX    c000.1331.c000.1339
  3508.     HEX    ffff.e3cf.7fff.c1c6
  3509. *
  3510.     HEX    71c7.fffe.fbef.ffff
  3511.     HEX    ffef.ffff.7fff.ffff
  3512.     HEX    3fff.ffff.1fff.ffff
  3513.     HEX    1fff.ffff.1fff.ffff
  3514.     HEX    1fff.ffff.1fff.ffff
  3515.     HEX    0fff.ffff.3fff.ffff
  3516.     HEX    7fff.ffff.ffff.ffff
  3517.     HEX    ffff.ffff.ffff.ffff
  3518.     HEX    ffff.ffff.ffff.ffff
  3519.     HEX    ffff.ffff.ffff.ffff
  3520.     HEX    ffff.fffe.ffff.ffff
  3521.     HEX    ffff.ffff.ffff.ffff
  3522.     HEX    ffff.fffe.ffff.fffc
  3523.     HEX    ffff.fffc.ffff.fffe
  3524.     HEX    ffff.ffff.ffff.f3ff
  3525.     HEX    ffff.e3ef.7fff.c1c6
  3526.     ENDR
  3527. *
  3528.     RSRC    ICN#,131,32
  3529.     HEX    71c7.fffe.cb2c.0001
  3530.     HEX    c62c.0001.604f.fff9
  3531.     HEX    3087.fff9.1900.0019
  3532.     HEX    1900.0019.1900.0019
  3533.     HEX    1909.1899.1e09.2499
  3534.     HEX    0c09.2499.0009.1899
  3535.     HEX    7000.0019.c800.0019
  3536.     HEX    c989.2319.ca49.2499
  3537.     HEX    ca49.2499.c989.2319
  3538.     HEX    c800.001f.c800.000f
  3539.     HEX    c988.c000.ca49.21ce
  3540.     HEX    ca49.2339.c988.c332
  3541.     HEX    c800.0324.c800.0308
  3542.     HEX    c800.0304.cfff.f322
  3543.     HEX    c000.0b31.c000.0b39
  3544.     HEX    ffff.f3cf.7fff.e1c6
  3545. *
  3546.     HEX    71c7.fffe.fbef.ffff
  3547.     HEX    ffef.ffff.7fff.ffff
  3548.     HEX    3fff.ffff.1fff.ffff
  3549.     HEX    1fff.ffff.1fff.ffff
  3550.     HEX    1fff.ffff.1fff.ffff
  3551.     HEX    0fff.ffff.0fff.ffff
  3552.     HEX    7fff.ffff.ffff.ffff
  3553.     HEX    ffff.ffff.ffff.ffff
  3554.     HEX    ffff.ffff.ffff.ffff
  3555.     HEX    ffff.ffff.ffff.ffff
  3556.     HEX    ffff.fffe.ffff.ffff
  3557.     HEX    ffff.ffff.ffff.ffff
  3558.     HEX    ffff.fffe.ffff.fffc
  3559.     HEX    ffff.fffc.ffff.fffe
  3560.     HEX    ffff.ffff.ffff.ffff
  3561.     HEX    ffff.f7ff.7fff.e7ce
  3562.     ENDR
  3563. *
  3564.     RSRC    ICN#,132,32
  3565.     HEX    71c7.fffe.cb2c.0001
  3566.     HEX    c62c.0001.604f.fff9
  3567.     HEX    3087.fff9.1900.0019
  3568.     HEX    197f.0019.1900.0019
  3569.     HEX    190f.f019.1e00.0019
  3570.     HEX    0c0f.f019.0000.0019
  3571.     HEX    7001.fc19.c800.0019
  3572.     HEX    c87f.fc19.c800.0019
  3573.     HEX    c80f.8019.c800.0019
  3574.     HEX    c87f.fe19.c800.001f
  3575.     HEX    c80f.f000.c800.01ce
  3576.     HEX    c803.c339.c800.0332
  3577.     HEX    c8ff.c324.c800.0308
  3578.     HEX    c800.0304.cfff.e332
  3579.     HEX    c000.1339.c000.133d
  3580.     HEX    ffff.f3cf.7fff.e1c6
  3581. *
  3582.     HEX    638f.fffe.f7cf.ffff
  3583.     HEX    ffcf.ffff.7fff.ffff
  3584.     HEX    3fff.ffff.1fff.ffff
  3585.     HEX    1fff.ffff.1fff.ffff
  3586.     HEX    1fff.ffff.1fff.ffff
  3587.     HEX    1fff.ffff.7fff.ffff
  3588.     HEX    ffff.ffff.ffff.ffff
  3589.     HEX    ffff.ffff.ffff.ffff
  3590.     HEX    ffff.ffff.ffff.ffff
  3591.     HEX    ffff.ffff.ffff.ffff
  3592.     HEX    ffff.fffe.ffff.fffe
  3593.     HEX    ffff.fffe.ffff.fffe
  3594.     HEX    ffff.fffe.ffff.fffc
  3595.     HEX    ffff.fff8.ffff.fffc
  3596.     HEX    ffff.fffe.ffff.f3ff
  3597.     HEX    ffff.f3ee.7fff.f1c6
  3598.     ENDR
  3599. *
  3600.     RSRC    WIND,256
  3601.     DATA    /40,/2,/326,/498
  3602.     DATA    /8
  3603.     DATA    #1,#0
  3604.     DATA    #0,#0
  3605.     DATA    0
  3606.     STR    "yerk.com"
  3607.     ENDR
  3608. *
  3609.     RSRC    BNDL,128
  3610.     ASC    'YERK'
  3611.     DATA    /0
  3612.     DATA    /2-1
  3613.     ASC    'ICN#'
  3614.     DATA    /5-1
  3615.     DATA    /0,/128,/1,/129,/2,/130
  3616.     DATA    /3,/131,/4,/132
  3617.     ASC    'FREF'
  3618.     DATA    /5-1
  3619.     DATA    /0,/128,/1,/129,/2,/130
  3620.     DATA    /3,/131,/4,/132
  3621.     ENDR
  3622. *
  3623.     RSRC    SIZE,-1
  3624.     DATA    /$5880
  3625.     DATA    1022976
  3626.     DATA    393216
  3627.     ENDR
  3628. *
  3629.     RSRC    vers,1
  3630.     DATA    $03688000
  3631.     DATA    /0000
  3632.          STR     "3.6.8"
  3633.          STR     "3.6.8 Yerkes Observatory"
  3634.          ENDR
  3635. *
  3636.          END
  3637.